diff --git a/API.md b/API.md
new file mode 100644
--- /dev/null
+++ b/API.md
@@ -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
+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/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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)
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/changelog.md b/changelog.md
new file mode 100644
--- /dev/null
+++ b/changelog.md
@@ -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.
diff --git a/examples/GpioServer.hs b/examples/GpioServer.hs
new file mode 100644
--- /dev/null
+++ b/examples/GpioServer.hs
@@ -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")
diff --git a/examples/MockServer.hs b/examples/MockServer.hs
new file mode 100644
--- /dev/null
+++ b/examples/MockServer.hs
@@ -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
diff --git a/mellon-web.cabal b/mellon-web.cabal
new file mode 100644
--- /dev/null
+++ b/mellon-web.cabal
@@ -0,0 +1,192 @@
+Name: mellon-web
+Version: 0.7.0.1
+Cabal-Version: >= 1.10
+Build-Type: Simple
+Author: Drew Hess
+Maintainer: Drew Hess
+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 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
diff --git a/mellon-web.paw b/mellon-web.paw
new file mode 100644
--- /dev/null
+++ b/mellon-web.paw
@@ -0,0 +1,387 @@
+
+
+
+
+
+ 134481920
+ 1E1D451C-4E87-4F1C-8A5D-6A76267CA5ED
+ 132
+
+
+
+ NSPersistenceFrameworkVersion
+ 640
+ NSStoreModelVersionHashes
+
+ LMCookieJar
+
+ Fttmf2L4PrGvKUF496+nqgVVGek45TjOe7sUMtjNg8I=
+
+ LMEnvironment
+
+ uzBoVFcO4YvR9/3ej4AJ1UOOsA/u5DKY2aemusoIseU=
+
+ LMEnvironmentDomain
+
+ yM1GPGHdquS8IWLtuczlNoqKhIhD9FW6IReSfFffJgs=
+
+ LMEnvironmentVariable
+
+ P8e0lYd5JZKRabS/eXVSOJ4oitilz67xtv+pLqW1Jqg=
+
+ LMEnvironmentVariableValue
+
+ my5hNPJ51oDCSa8EgdNxWAnRcDLcERUGjtuXnzhSxQ0=
+
+ LMKeyValue
+
+ bIXXbyYF2xAv2MXg8JTVFsslmMKuvsfnR86QdUcFkdM=
+
+ LMRequest
+
+ kYB6By9dZHqmH3YNw3h9tYPoxeG5ZWHPfhLXXp7OLFs=
+
+ LMRequestGroup
+
+ N3ml+gYVWc4m0LSGLnBDJ37p9isOc41y+TtaM0Eacrc=
+
+ LMRequestTreeItem
+
+ ak+hYb/lDeG55U0kgGvU5ej7HUltUj0RTrX5z/izNrs=
+
+
+ NSStoreModelVersionHashesVersion
+ 3
+ NSStoreModelVersionIdentifiers
+
+ LMDocumentVersion3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/Mellon/Web/Client.hs b/src/Mellon/Web/Client.hs
new file mode 100644
--- /dev/null
+++ b/src/Mellon/Web/Client.hs
@@ -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
+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
diff --git a/src/Mellon/Web/Server.hs b/src/Mellon/Web/Server.hs
new file mode 100644
--- /dev/null
+++ b/src/Mellon/Web/Server.hs
@@ -0,0 +1,22 @@
+{-|
+Module : Mellon.Web.Server
+Description : Top-level server re-exports
+Copyright : (c) 2016, Drew Hess
+License : BSD3
+Maintainer : Drew Hess
+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
diff --git a/src/Mellon/Web/Server/API.hs b/src/Mellon/Web/Server/API.hs
new file mode 100644
--- /dev/null
+++ b/src/Mellon/Web/Server/API.hs
@@ -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
+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 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
diff --git a/src/Mellon/Web/Server/DocsAPI.hs b/src/Mellon/Web/Server/DocsAPI.hs
new file mode 100644
--- /dev/null
+++ b/src/Mellon/Web/Server/DocsAPI.hs
@@ -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
+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/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import Test.Hspec
+import Spec
+
+main :: IO ()
+main = hspec spec
diff --git a/test/Mellon/Web/ClientSpec.hs b/test/Mellon/Web/ClientSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Mellon/Web/ClientSpec.hs
@@ -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
diff --git a/test/Mellon/Web/ServerSpec.hs b/test/Mellon/Web/ServerSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Mellon/Web/ServerSpec.hs
@@ -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"]}
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
diff --git a/test/hlint.hs b/test/hlint.hs
new file mode 100644
--- /dev/null
+++ b/test/hlint.hs
@@ -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