diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -76,4 +76,4 @@ always run it (or any `mellon-web` server) behind a secure proxy web service or equivalent HTTP(S)-based authentication mechanism. -[![Travis CI build status](https://travis-ci.org/dhess/mellon.svg?branch=v0.7.0)](https://travis-ci.org/dhess/mellon) +[![Travis CI build status](https://travis-ci.org/dhess/mellon.svg?branch=master)](https://travis-ci.org/dhess/mellon) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,11 @@ +## 0.7.0.3 (2016-09-23) + +- Bump servant upper bounds. + +## 0.7.0.2 (2016-09-23) + +- Add an "--active-low" flag to `gpio-mellon-server` example. + ## 0.7.0.1 (2016-06-13) - Packaging fixes only. diff --git a/examples/GpioServer.hs b/examples/GpioServer.hs --- a/examples/GpioServer.hs +++ b/examples/GpioServer.hs @@ -21,6 +21,7 @@ data GlobalOptions = GlobalOptions {_port :: !Int ,_minUnlockTime :: !Int + ,_activeLow :: !Bool ,_cmd :: !Command} data Command @@ -50,13 +51,20 @@ metavar "INT" <> value 1 <> help "Minimum unlock time in seconds") <*> + switch (long "active-low" <> + short 'l' <> + help "Pin is active low") <*> 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 -> +runTCPServerSysfs :: Pin -> Int -> NominalDiffTime -> Bool -> IO () +runTCPServerSysfs pin port minUnlockTime lowFlag = runSysfsGpioIO $ + withOutputPin pin OutputDefault (Just $ activeLevel lowFlag) Low $ \p -> liftIO $ runTCPServer minUnlockTime (sysfsGpioDevice p) port + where + activeLevel :: Bool -> PinActiveLevel + activeLevel False = ActiveHigh + activeLevel True = ActiveLow runTCPServer :: NominalDiffTime -> Device d -> Int -> IO () runTCPServer minUnlock device port = @@ -65,10 +73,10 @@ runSettingsSocket (setPort port $ setHost "*" defaultSettings) sock (docsApp cc) run :: GlobalOptions -> IO () -run (GlobalOptions listenPort minUnlockTime (Sysfs (SysfsOptions pinNumber))) = +run (GlobalOptions listenPort minUnlockTime activeLow (Sysfs (SysfsOptions pinNumber))) = let pin = Pin pinNumber in - runTCPServerSysfs pin listenPort (fromIntegral minUnlockTime) + runTCPServerSysfs pin listenPort (fromIntegral minUnlockTime) activeLow main :: IO () main = execParser opts >>= run diff --git a/examples/ScheduleUnlock.hs b/examples/ScheduleUnlock.hs new file mode 100644 --- /dev/null +++ b/examples/ScheduleUnlock.hs @@ -0,0 +1,128 @@ +-- | This is a one-shot program which, when run, checks the specified +-- unlock window against the current time. If the current time is +-- within the window, the program unlocks the specified Mellon +-- controller until the end of the window. If the current time is +-- outside the window, the program locks the controller. +-- +-- The program is intended to be run from a cron job which runs once a +-- day at the start of the window, therefore implementing a very +-- simple, "unlock this door every day from time X until time Y" +-- system. Because it checks the current time against the unlock +-- window, it can also be run at intervals (e.g., once a minute) or +-- @reboot to make the system slightly more robust. + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad.Catch.Pure (runCatch) +import Control.Monad.Trans.Except (runExceptT) +import Data.ByteString.Char8 as C8 (unpack) +import Data.Time.Clock + (NominalDiffTime, UTCTime(..), addUTCTime) +import qualified Data.Time.LocalTime as Time + (LocalTime(..), TimeOfDay(..), ZonedTime(..), getZonedTime, + zonedTimeToUTC) +import Mellon.Web.Client (State(..), putState) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.HTTP.Types (Status(..)) +import Options.Applicative +import Servant.Client (BaseUrl, ServantError(..), parseBaseUrl) +import System.Exit (ExitCode(..), exitWith) + +data GlobalOptions = + GlobalOptions {_url :: !BaseUrl + ,_cmd :: !Command} + +data Command + = LocalTime LocalTimeOptions + +data LocalTimeOptions = + LocalTimeOptions {_localTimeStart :: !Time.TimeOfDay + ,_localTimeEnd :: !Time.TimeOfDay} + +localTimeCmd :: Parser Command +localTimeCmd = LocalTime <$> localTimeOptions + +localTimeOptions :: Parser LocalTimeOptions +localTimeOptions = + LocalTimeOptions <$> + argument auto (metavar "HH:MM:SS" <> + help "Unlock window start time (local time, 24H format)") <*> + argument auto (metavar "HH:MM:SS" <> + help "Unlock window end time (local time, 24H format)") + +parseServiceUrl :: String -> ReadM BaseUrl +parseServiceUrl s = + case runCatch $ parseBaseUrl s of + Left _ -> readerError $ "Invalid service URL: " ++ s + Right url -> return url + +cmds :: Parser GlobalOptions +cmds = + GlobalOptions <$> + argument (str >>= parseServiceUrl) + (metavar "URL" <> + help "Mellon server base URL") <*> + hsubparser + (command "localtime" (info localTimeCmd (progDesc "Unlock window specified in local time"))) + +oneDay :: NominalDiffTime +oneDay = 60 * 60 * 24 + +-- | Convert a 'TimeOfDay' to a 'UTCTime', using the given 'ZonedTime' +-- as the point of reference; i.e., the 'TimeOfDay' is relative to the +-- 'ZonedTime''s (local) day. +timeOfDayToUTC :: Time.TimeOfDay -> Time.ZonedTime -> UTCTime +timeOfDayToUTC tod zt = + let localDay = Time.localDay $ Time.zonedTimeToLocalTime zt + localTz = Time.zonedTimeZone zt + localTime = Time.LocalTime localDay tod + in Time.zonedTimeToUTC $ Time.ZonedTime localTime localTz + +run :: GlobalOptions -> IO () +run (GlobalOptions baseUrl (LocalTime (LocalTimeOptions localStart localEnd))) = + do zonedNow <- Time.getZonedTime + let utcStart = timeOfDayToUTC localStart zonedNow + adjustEnd = + if localStart > localEnd + then oneDay + else 0 + utcEnd = addUTCTime adjustEnd $ timeOfDayToUTC localEnd zonedNow + utcNow = Time.zonedTimeToUTC zonedNow + go utcStart utcEnd utcNow baseUrl + where + go :: UTCTime -> UTCTime -> UTCTime -> BaseUrl -> IO () + go start end now url = + let state = if now >= start && now < end + then Unlocked end + else Locked + in do manager <- newManager tlsManagerSettings + runExceptT (putState state manager url) >>= \case + Right status -> + do putStrLn $ show status + exitWith ExitSuccess + Left e -> + do putStrLn $ "Mellon service error: " ++ prettyServantError e + exitWith $ ExitFailure 1 + prettyServantError :: ServantError -> String + prettyServantError (FailureResponse status _ _) = + show (statusCode status) ++ " " ++ (C8.unpack $ statusMessage status) + prettyServantError (DecodeFailure _ _ _) = + "decode failure" + prettyServantError (UnsupportedContentType _ _) = + "unsupported content type" + prettyServantError (InvalidContentTypeHeader _ _) = + "invalid content type header" + prettyServantError (ConnectionError _) = + "connection refused" + +main :: IO () +main = execParser opts >>= run + where opts = + info (helper <*> cmds) + (fullDesc <> + progDesc "Unlock a mellon controller within a specified time window" <> + header "mellon-schedule-unlock") diff --git a/mellon-web.cabal b/mellon-web.cabal --- a/mellon-web.cabal +++ b/mellon-web.cabal @@ -1,5 +1,5 @@ Name: mellon-web -Version: 0.7.0.1 +Version: 0.7.0.3 Cabal-Version: >= 1.10 Build-Type: Simple Author: Drew Hess @@ -60,6 +60,11 @@ Default: True Manual: True +-- Build the unlock client example +Flag client-unlock-example + Default: True + Manual: True + Library Default-Language: Haskell2010 HS-Source-Dirs: src @@ -82,11 +87,11 @@ , 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 + , servant >= 0.7.1 && < 0.10 + , servant-client >= 0.7.1 && < 0.10 + , servant-docs >= 0.7.1 && < 0.10 + , servant-lucid >= 0.7.1 && < 0.10 + , servant-server >= 0.7.1 && < 0.10 , text == 1.2.* , time >= 1.5 && < 2 , transformers >= 0.4.2 && < 0.6 @@ -132,6 +137,33 @@ , transformers , warp +Executable mellon-schedule-unlock + Main-Is: ScheduleUnlock.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: LambdaCase + , OverloadedStrings + If !flag(client-unlock-example) + Buildable: False + Else + Build-Depends: base + , bytestring + , exceptions + , http-client + , http-client-tls + , http-types + , mellon-core + , mellon-web + , mtl + , network + , optparse-applicative + , servant-client + , time + , transformers + Test-Suite hlint Type: exitcode-stdio-1.0 Default-Language: Haskell2010 @@ -188,5 +220,4 @@ Source-Repository this Type: git Location: git://github.com/dhess/mellon.git - Branch: v0.7.0 - Tag: v0.7.0.1a + Tag: v0.7.0.3