diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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*. diff --git a/NgxExport/Tools.hs b/NgxExport/Tools.hs --- a/NgxExport/Tools.hs +++ b/NgxExport/Tools.hs @@ -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 diff --git a/ngx-export-tools.cabal b/ngx-export-tools.cabal --- a/ngx-export-tools.cabal +++ b/ngx-export-tools.cabal @@ -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 @@ -26,5 +26,5 @@ exposed-modules: NgxExport.Tools - ghc-options: -Wall -Wno-unused-top-binds -Wno-unused-matches + ghc-options: -Wall