ngx-export-tools 0.1.2.0 → 0.2.0.0
raw patch · 3 files changed
+208/−151 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ NgxExport.Tools: readFromByteString :: Read a => ByteString -> Maybe a
+ NgxExport.Tools: readFromByteStringAsJSON :: FromJSON a => ByteString -> Maybe a
Files
- Changelog.md +5/−0
- NgxExport/Tools.hs +201/−149
- ngx-export-tools.cabal +2/−2
Changelog.md view
@@ -1,3 +1,8 @@+### 0.2.0.0++- Added functions *readFromByteString* and *readFromByteStringAsJSON*.+- Many bug fixes in the builder of simple services.+ ### 0.1.2.0 - Added function *ngxRequestPtr*.
NgxExport/Tools.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface, TypeFamilies #-}-{-# LANGUAGE DeriveGeneric, DeriveLift, NumDecimals #-}+{-# LANGUAGE EmptyDataDecls, DeriveGeneric, DeriveLift, NumDecimals #-} ----------------------------------------------------------------------------- -- |@@ -23,9 +23,13 @@ ,terminateWorkerProcess ,ngxRequestPtr ,ngxNow- ,threadDelaySec+ -- *** Time intervals ,TimeInterval (..) ,toSec+ ,threadDelaySec+ -- *** Reading custom types from /ByteStrings/+ ,readFromByteString+ ,readFromByteStringAsJSON -- * Exporters of simple services -- $simpleServices ,ServiceMode (..)@@ -94,10 +98,6 @@ ngxNow :: IO CTime ngxNow = ngxCachedTimePtr >>= peek >>= peek . castPtr --- | Delays current thread for the specified number of seconds.-threadDelaySec :: Int -> IO ()-threadDelaySec = threadDelay . (* 1e6)- -- | Time intervals. data TimeInterval = Hr Int -- ^ Hours | Min Int -- ^ Minutes@@ -115,6 +115,41 @@ toSec (HrMin h m) = 3600 * h + 60 * m toSec (MinSec m s) = 60 * m + s +-- | Delays current thread for the specified number of seconds.+threadDelaySec :: Int -> IO ()+threadDelaySec = threadDelay . (* 1e6)++data Readable a+data ReadableAsJSON a++class FromByteString a where+ type WrappedT a+ fromByteString :: Maybe a -> ByteString -> Maybe (WrappedT a)++instance Read a => FromByteString (Readable a) where+ type WrappedT (Readable a) = a+ fromByteString = const $ readMay . C8.unpack++instance FromJSON a => FromByteString (ReadableAsJSON a) where+ type WrappedT (ReadableAsJSON a) = a+ fromByteString = const decodeStrict++instance FromByteString ByteString where+ type WrappedT ByteString = ByteString+ fromByteString = const Just++-- | Reads a custom type deriving 'Read' from a 'ByteString'.+--+-- Returns 'Nothing' if reading fails.+readFromByteString :: Read a => ByteString -> Maybe a+readFromByteString = fromByteString (Nothing :: Maybe (Readable a))++-- | Reads a custom type deriving 'FromJSON' from a 'ByteString'.+--+-- Returns 'Nothing' if reading fails.+readFromByteStringAsJSON :: FromJSON a => ByteString -> Maybe a+readFromByteStringAsJSON = fromByteString (Nothing :: Maybe (ReadableAsJSON a))+ -- $simpleServices -- -- There are a number of exporters for /simple services/. Here /simplicity/@@ -149,29 +184,50 @@ -- 'ngxExportSimpleService' \'test $ -- 'PersistentService' $ Just $ 'Sec' 10 ----- newtype ConfRead = ConfRead Int deriving (Read, Show)+-- testRead :: (Read a, Show a) => a -> Bool -> IO L.ByteString+-- testRead = const . return . C8L.pack . show ----- testRead :: ConfRead -> Bool -> IO L.ByteString--- __/testRead/__ c = const $ return $ C8L.pack $ show c--- 'ngxExportSimpleServiceTyped' \'testRead \'\'ConfRead $+-- testReadInt :: Int -> Bool -> IO L.ByteString+-- __/testReadInt/__ = testRead+-- 'ngxExportSimpleServiceTyped' \'testReadInt \'\'Int $ -- 'PersistentService' $ Just $ 'Sec' 10 ----- data ConfReadJSON = ConfReadJSONCon1 Int--- | ConfReadJSONCon2 deriving (Generic, Show)--- instance FromJSON ConfReadJSON+-- newtype Conf = Conf Int deriving (Read, Show) ----- testReadJSON :: ConfReadJSON -> Bool -> IO L.ByteString--- __/testReadJSON/__ c = const $ return $ C8L.pack $ show c--- 'ngxExportSimpleServiceTypedAsJSON' \'testReadJSON \'\'ConfReadJSON+-- testReadConf :: Conf -> Bool -> IO L.ByteString+-- __/testReadConf/__ = testRead+-- 'ngxExportSimpleServiceTyped' \'testReadConf \'\'Conf $+-- 'PersistentService' $ Just $ 'Sec' 10+--+-- testReadJSON :: (FromJSON a, Show a) => a -> Bool -> IO L.ByteString+-- testReadJSON = const . return . C8L.pack . show+--+-- data ConfJSON = ConfJSONCon1 Int+-- | ConfJSONCon2 deriving (Generic, Show)+-- instance FromJSON ConfJSON+--+-- testReadConfJSON :: ConfJSON -> Bool -> IO L.ByteString+-- __/testReadConfJSON/__ = testReadJSON+-- 'ngxExportSimpleServiceTypedAsJSON' \'testReadConfJSON \'\'ConfJSON -- 'SingleShotService' -- @ ----- Here three simple services of various types are defined: /test/, /testRead/,--- and /testReadJSON/. As soon as they merely echo their arguments into their--- service variables, they must sleep for a while between iterations. Sleeps--- are managed by strategies defined in type 'ServiceMode'. There are basically--- three sleeping strategies:+-- Here four simple services of various types are defined: /test/,+-- /testReadInt/, /testReadConf/, and /testReadConfJSON/. Service /testReadInt/+-- is not a good example though. The problem is that simple services build+-- 'IORef' /storages/ to save their configurations for faster access in future+-- iterations. The name of a storage consists of the name of its type prefixed+-- with __/storage_/__, which means that it's wiser to use custom types or+-- wrappers of well-known types (such as /Conf/) in order to avoid exhaustion+-- of top-level names. In general, this also means that it's not possible to+-- declare in a single Nginx configuration script two or more /typed/ simple+-- services with identical names of their configuration types. --+-- As soon as all the services in the example merely echo their arguments into+-- their service variables, they must sleep for a while between iterations.+-- Sleeps are managed by strategies defined in type 'ServiceMode'. There are+-- basically three sleeping strategies:+-- -- * Periodical sleeps (for example, @'PersistentService' $ Just $ 'Sec' 10@) -- * No sleeps between iterations (@'PersistentService' Nothing@) -- * /Single-shot/ services (@'SingleShotService'@)@@ -183,8 +239,8 @@ -- afterwards it merely returns empty values: as such, this strategy should be -- accompanied by Nginx directive __/haskell_service_var_ignore_empty/__. ----- All three services ignore their second parameter (of type 'Prelude.Bool')--- denoting the first run of the service.+-- All the services in the example ignore their second parameter (of type+-- 'Prelude.Bool') which denotes the first run of the service. -- -- File __/nginx.conf/__. --@@ -202,17 +258,24 @@ -- -- haskell load \/var\/lib\/nginx\/test_tools.so; ----- haskell_run_service __/simpleService_test/__ $hs_test+-- haskell_run_service __/simpleService_test/__+-- $hs_test -- test; ----- haskell_run_service __/simpleService_testRead/__ $hs_testRead--- \'ConfRead 20\';+-- haskell_run_service __/simpleService_testReadInt/__+-- $hs_testReadInt+-- 5000000; ----- haskell_run_service __/simpleService_testReadJSON/__ $hs_testReadJSON--- \'{\"tag\":\"ConfReadJSONCon1\", \"contents\":56}\';+-- haskell_run_service __/simpleService_testReadConf/__+-- $hs_testReadConf+-- \'Conf 20\'; ----- haskell_service_var_ignore_empty $hs_testReadJSON;+-- haskell_run_service __/simpleService_testReadConfJSON/__+-- $hs_testReadConfJSON+-- \'{\"tag\":\"ConfJSONCon1\", \"contents\":56}\'; --+-- haskell_service_var_ignore_empty $hs_testReadConfJSON;+-- -- server { -- listen 8010; -- server_name main;@@ -220,10 +283,11 @@ -- access_log \/tmp\/nginx-test-haskell-access.log; -- -- location \/ {--- echo \"Service variables:\";--- echo \" hs_test: $hs_test\";--- echo \" hs_testRead: $hs_testRead\";--- echo \" hs_testReadJSON: $hs_testReadJSON\";+-- echo \"Service variables:";+-- echo \" hs_test: $hs_test";+-- echo \" hs_testReadInt: $hs_testReadInt";+-- echo \" hs_testReadConf: $hs_testReadConf";+-- echo \" hs_testReadConfJSON: $hs_testReadConfJSON"; -- } -- } -- }@@ -237,27 +301,9 @@ -- > $ curl 'http://localhost:8010/' -- > Service variables: -- > hs_test: test--- > hs_testRead: ConfRead 20--- > hs_testReadJSON: ConfReadJSONCon1 56--newtype Readable a = Readable a-newtype ReadableAsJSON a = ReadableAsJSON a--class FromByteString a where- type WrappedT a- fromByteString :: Maybe a -> ByteString -> Maybe (WrappedT a)--instance Read a => FromByteString (Readable a) where- type WrappedT (Readable a) = a- fromByteString = const $ readMay . C8.unpack--instance FromJSON a => FromByteString (ReadableAsJSON a) where- type WrappedT (ReadableAsJSON a) = a- fromByteString = const decodeStrict--instance FromByteString ByteString where- type WrappedT ByteString = ByteString- fromByteString = const Just+-- > hs_testReadInt: 5000000+-- > hs_testReadConf: Conf 20+-- > hs_testReadConfJSON: ConfJSONCon1 56 -- | Defines a sleeping strategy. --@@ -274,101 +320,103 @@ simpleServiceWrap f = f ngxExportSimpleService' :: Name -> Maybe (Name, Bool) -> ServiceMode -> Q [Dec]-ngxExportSimpleService' f c m = concat <$> sequence- [sequence $- (if hasConf- then [sigD nameC [t|IORef (Maybe $(conT nameConC))|]- ,funD nameC [clause []- (normalB- [|unsafePerformIO $ newIORef Nothing|]- )- []- ]- ,pragInlD nameC NoInline FunLike AllPhases- ]- else []- )- ++- [sigD nameSf [t|ByteString -> Bool -> IO L.ByteString|]- ,funD nameSf- [clause [[p|confBs_|], [p|fstRun_|]]- (normalB- [|do- conf_data_ <- $(initConf)- $(waitTime)- $(serviceWrap)- |]- )- []+ngxExportSimpleService' f c m = do+ confBs <- newName "confBs_"+ fstRun <- newName "fstRun_"+ let nameSsf = mkName $ "simpleService_" ++ nameBase f+ hasConf = isJust c+ (sNameC, typeC, isJSON) =+ if hasConf+ then let c' = fromJust c+ tName = nameBase $ fst c'+ in (mkName $ "storage_" ++ tName+ ,conT $ mkName tName+ ,snd c'+ )+ else (mkName "storage_dummy__"+ ,conT $ mkName "Dummy__"+ ,False+ )+ initConf =+ let eConfBs = varE confBs+ in if hasConf+ then let storage = varE sNameC+ readConf = if isJSON+ then [|readFromByteStringAsJSON|]+ else [|readFromByteString|]+ in [|readIORef $(storage) >>=+ maybe (do+ let conf_data__ =+ $(readConf) $(eConfBs)+ when (isNothing conf_data__)+ terminateWorkerProcess+ writeIORef $(storage) conf_data__+ return conf_data__+ ) (return . Just)+ |]+ else [|return $+ fromByteString (Nothing :: Maybe ByteString)+ $(eConfBs)+ |]+ (waitTime, serviceWrap) =+ let eF = varE f+ eFstRun = varE fstRun+ in case m of+ PersistentService i ->+ (if isJust i+ then let t = fromJust i+ in [|unless $(eFstRun) $+ threadDelaySec $ toSec t+ |]+ else [|return ()|]+ ,[|\conf_data__ ->+ simpleServiceWrap+ $(eF) (fromJust conf_data__) $(eFstRun)+ |]+ )+ SingleShotService ->+ ([|unless $(eFstRun) $+ threadDelaySec $ toSec $ Hr 1|]+ ,[|\conf_data__ ->+ if $(eFstRun)+ then simpleServiceWrap+ $(eF) (fromJust conf_data__)+ $(eFstRun)+ else return L.empty+ |]+ )+ concat <$> sequence+ [sequence $+ (if hasConf+ then [sigD sNameC [t|IORef (Maybe $(typeC))|]+ ,funD sNameC [clause []+ (normalB+ [|unsafePerformIO $+ newIORef Nothing+ |]+ )+ []+ ]+ ,pragInlD sNameC NoInline FunLike AllPhases+ ]+ else []+ )+ +++ [sigD nameSsf [t|ByteString -> Bool -> IO L.ByteString|]+ ,funD nameSsf+ [clause [varP confBs, varP fstRun]+ (normalB+ [|do+ conf_data_ <- $(initConf)+ $(waitTime)+ $(serviceWrap) conf_data_+ |]+ )+ []+ ] ]+ ,ngxExportServiceIOYY nameSsf ]- ,ngxExportServiceIOYY nameSf- ]- where sfName = "simpleService_" ++ nameBase f- nameSf = mkName sfName- hasConf = isJust c- (cName, isJSON) = if hasConf- then let c' = fromJust c- in ("storage_" ++ nameBase (fst c')- , snd c'- )- else ("dummy__", False)- nameC = mkName cName- nameConC = mkName $ if hasConf- then let c' = fromJust c- in nameBase (fst c')- else "Dummy__"- confType = if isJSON- then [t|ReadableAsJSON|]- else [t|Readable|]- initConf =- if hasConf- then [|readIORef $(varE nameC) >>=- maybe (do- let conf_data__ =- fromByteString- (Nothing :: Maybe- ($(confType)- $(conT nameConC)- )- ) confBs_- when (isNothing conf_data__)- terminateWorkerProcess- writeIORef $(varE nameC) conf_data__- return conf_data__- ) (return . Just)- |]- else [|do- let conf_data__ =- fromByteString- (Nothing :: Maybe ByteString) confBs_- when (isNothing conf_data__)- terminateWorkerProcess- return conf_data__- |]- (waitTime, serviceWrap) =- case m of- PersistentService i ->- (if isJust i- then let t = fromJust i- in [|unless fstRun_ $- threadDelaySec $ toSec t- |]- else [|return ()|]- ,[|simpleServiceWrap- $(varE f) (fromJust conf_data_) fstRun_- |]- )- SingleShotService ->- ([|unless fstRun_ $- threadDelaySec $ toSec $ Hr 1- |]- ,[|if fstRun_- then simpleServiceWrap- $(varE f) (fromJust conf_data_) fstRun_- else return L.empty- |]- ) -- | Exports a simple service with specified name and service mode. --@@ -384,7 +432,9 @@ -- The service expects an object of a custom type deriving 'Read' as its -- first argument. For the sake of efficiency, this object gets deserialized -- into a global 'IORef' data storage on the first service run to be further--- accessed directly from this storage.+-- accessed directly from this storage. The storage can be accessed from+-- elsewhere by name comprised of the name of the custom type prefixed with+-- __/storage_/__. The stored data is wrapped in 'Maybe' container. ngxExportSimpleServiceTyped :: Name -- ^ Name of the service -> Name -- ^ Name of the custom type -> ServiceMode -- ^ Service mode@@ -397,7 +447,9 @@ -- The service expects an object of a custom type deriving 'FromJSON' as its -- first argument. For the sake of efficiency, this object gets deserialized -- into a global 'IORef' data storage on the first service run to be further--- accessed directly from this storage.+-- accessed directly from this storage. The storage can be accessed from+-- elsewhere by name comprised of the name of the custom type prefixed with+-- __/storage_/__. The stored data is wrapped in 'Maybe' container. ngxExportSimpleServiceTypedAsJSON :: Name -- ^ Name of the service -> Name -- ^ Name of the custom type -> ServiceMode -- ^ Service mode
ngx-export-tools.cabal view
@@ -1,5 +1,5 @@ name: ngx-export-tools-version: 0.1.2.0+version: 0.2.0.0 synopsis: Extra tools for Nginx haskell module description: Extra tools for <http://github.com/lyokha/nginx-haskell-module Nginx haskell module>@@ -26,5 +26,5 @@ exposed-modules: NgxExport.Tools - ghc-options: -Wall -Wno-unused-top-binds -Wno-unused-matches+ ghc-options: -Wall