diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,8 @@ +### 1.2.6.1 + +- Reimplement parts of *voidService* in terms of *voidHandler'*. +- Refactor *ngxExportSimpleService'*. + ### 1.2.6 - Service *voidService* was reimplemented as a *split* service with the first diff --git a/NgxExport/Tools/Combinators.hs b/NgxExport/Tools/Combinators.hs --- a/NgxExport/Tools/Combinators.hs +++ b/NgxExport/Tools/Combinators.hs @@ -140,8 +140,8 @@ voidService :: a -- ^ Ignored configuration -> Bool -- ^ Ignored boolean value -> IO L.ByteString -voidService = splitService (const $ return L.empty) $ - const $ forever $ threadDelaySec $ toSec $ Hr 24 +voidService = splitService (voidHandler' $ return ()) $ + voidHandler' $ forever $ threadDelaySec $ toSec $ Hr 24 -- | A persistent service which waits for 24 hours before restart. -- diff --git a/NgxExport/Tools/SimpleService.hs b/NgxExport/Tools/SimpleService.hs --- a/NgxExport/Tools/SimpleService.hs +++ b/NgxExport/Tools/SimpleService.hs @@ -305,106 +305,99 @@ -- | Single-shot service | SingleShotService -isPersistentMode :: ServiceMode -> Bool -isPersistentMode (PersistentService _) = True -isPersistentMode _ = False +type TypedConf = (Name, (Bool, Bool)) -- (tName, (isJSON, storeConf)) -ngxExportSimpleService' :: Name -> Maybe (Name, (Bool, Bool)) -> ServiceMode -> - Q [Dec] +ngxExportSimpleService' :: Name -> Maybe TypedConf -> ServiceMode -> Q [Dec] ngxExportSimpleService' f c m = do confBs <- newName "confBs_" - fstRun <- newName "fstRun_" let nameF = nameBase f - nameSsf = mkName $ "simpleService_" ++ nameF - (hasConf, conf) = maybe (False, undefined) (True ,) c - (sNameC, typeC, makeStorage, (readStorage, writeStorage), - readConf, unreadableConfMsg) = - if hasConf - then let ((tName, tNameBase), (isJSON, storeConf)) = - first (id &&& nameBase) conf - storeConf' = storeConf && isPersistentMode m - sName = mkName $ - "storage_" ++ tNameBase ++ '_' : nameF - storage = varE sName - in (sName - ,conT tName - ,storeConf' - ,if storeConf' - then ([|readIORef $(storage)|] - ,[|writeIORef $(storage)|] - ) - else ([|return Nothing|] - ,[|const $ return ()|] - ) - ,if isJSON - then [|readFromByteStringAsJSON|] - else [|readFromByteString|] - ,"Configuration " ++ tNameBase ++ " is not readable" - ) - else undefined - initConf = - let eConfBs = varE confBs - in if hasConf - then [|$(readStorage) >>= - maybe (do - let conf_data__ = - $(readConf) $(eConfBs) - when (isNothing conf_data__) $ - terminateWorkerProcess - unreadableConfMsg - $(writeStorage) conf_data__ - return conf_data__ - ) (return . Just) - |] - else [|return $ Just $(eConfBs)|] + eConfBs = varE confBs + (makeStorage, initConf) = + flip (maybe ([], [|return $ Just $(eConfBs)|])) c $ \conf -> + let ((tName, tNameBase), (isJSON, storeConf)) = + first (id &&& nameBase) conf + storeConf' = + case m of + PersistentService _ -> storeConf + _ -> False + sName = mkName $ "storage_" ++ tNameBase ++ '_' : nameF + eStorage = varE sName + (readStorage, writeStorage) = + if storeConf' + then ([|readIORef $(eStorage)|] + ,[|writeIORef $(eStorage)|] + ) + else ([|return Nothing|] + ,[|const $ return ()|] + ) + readConf = + if isJSON + then [|readFromByteStringAsJSON|] + else [|readFromByteString|] + noReadConfMsg = + "Configuration " ++ tNameBase ++ " is not readable" + in (if storeConf' + then [sigD sName [t|IORef (Maybe $(conT tName))|] + ,funD sName + [clause [] + (normalB + [|unsafePerformIO $ newIORef Nothing|] + ) + [] + ] + ,pragInlD sName NoInline FunLike AllPhases + ] + else [] + ,[|$(readStorage) >>= + maybe (do + let conf_data__ = $(readConf) $(eConfBs) + when (isNothing conf_data__) $ + terminateWorkerProcess noReadConfMsg + $(writeStorage) conf_data__ + return conf_data__ + ) (return . Just) + |] + ) + fstRun <- newName "fstRun_" + let nameSsf = mkName $ "simpleService_" ++ nameF + eF = varE f + eFstRun = varE fstRun + runPersistentService = [|flip $(eF) $(eFstRun)|] (waitTime, runService) = - let eF = varE f - eFstRun = varE fstRun - runPersistentService = [|flip $(eF) $(eFstRun)|] - in case m of - PersistentService (Just t) -> - ([|const $ unless $(eFstRun) $ threadDelaySec $ toSec t|] - ,runPersistentService - ) - PersistentService Nothing -> - ([|const $ return ()|] - ,runPersistentService - ) - SingleShotService -> - ([|\conf_data__ -> unless $(eFstRun) $ - handle - (const $ void $ $(eF) conf_data__ False :: - WorkerProcessIsExiting -> IO () - ) $ forever $ threadDelaySec $ toSec $ Hr 24 - |] - ,[|\conf_data__ -> - if $(eFstRun) - then $(eF) conf_data__ True - else return L.empty - |] - ) + case m of + PersistentService (Just t) -> + ([|const $ unless $(eFstRun) $ threadDelaySec $ toSec t|] + ,runPersistentService + ) + PersistentService Nothing -> + ([|const $ return ()|] + ,runPersistentService + ) + SingleShotService -> + ([|\conf_data__ -> unless $(eFstRun) $ + handle + (const $ void $ $(eF) conf_data__ False :: + WorkerProcessIsExiting -> IO () + ) $ forever $ threadDelaySec $ toSec $ Hr 24 + |] + ,[|\conf_data__ -> + if $(eFstRun) + then $(eF) conf_data__ True + else return L.empty + |] + ) concat <$> sequence [sequence $ - (if hasConf && makeStorage - then [sigD sNameC [t|IORef (Maybe $(typeC))|] - ,funD sNameC - [clause [] - (normalB [|unsafePerformIO $ newIORef Nothing|]) - [] - ] - ,pragInlD sNameC NoInline FunLike AllPhases - ] - else [] - ) - ++ + makeStorage ++ [sigD nameSsf [t|ByteString -> Bool -> IO L.ByteString|] ,funD nameSsf [clause [varP confBs, varP fstRun] - (normalB [|do - conf_data_ <- fromJust <$> $(initConf) - $(waitTime) conf_data_ - $(runService) conf_data_ - |] + (normalB + [|do + conf_data_ <- fromJust <$> $(initConf) + $(waitTime) conf_data_ + $(runService) conf_data_ + |] ) [] ] 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: 1.2.6 +version: 1.2.6.1 synopsis: Extra tools for Nginx Haskell module description: Extra tools for .