mellon-web 0.7.0.1 → 0.7.0.3
raw patch · 5 files changed
+189/−14 lines, 5 filesdep +http-client-tlsdep ~basedep ~bytestringdep ~exceptionsnew-component:exe:mellon-schedule-unlock
Dependencies added: http-client-tls
Dependency ranges changed: base, bytestring, exceptions, http-client, http-types, mellon-core, network, optparse-applicative, servant, servant-client, servant-docs, servant-lucid, servant-server, time, transformers
Files
- README.md +1/−1
- changelog.md +8/−0
- examples/GpioServer.hs +13/−5
- examples/ScheduleUnlock.hs +128/−0
- mellon-web.cabal +39/−8
README.md view
@@ -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. -[](https://travis-ci.org/dhess/mellon)+[](https://travis-ci.org/dhess/mellon)
changelog.md view
@@ -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.
examples/GpioServer.hs view
@@ -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
+ examples/ScheduleUnlock.hs view
@@ -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")
mellon-web.cabal view
@@ -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 <src@drewhess.com>@@ -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