{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : NgxExport.Tools.SimpleService -- Copyright : (c) Alexey Radkov 2018-2023 -- License : BSD-style -- -- Maintainer : alexey.radkov@gmail.com -- Stability : stable -- Portability : non-portable (requires Template Haskell) -- ----------------------------------------------------------------------------- module NgxExport.Tools.SimpleService ( -- * Exporters of simple services -- $description -- *** Preloading storages of typed simple services -- $preload -- * Exported data and functions ServiceMode (..) ,ngxExportSimpleService ,ngxExportSimpleServiceTyped ,ngxExportSimpleServiceTypedAsJSON -- * Type declarations ,NgxExportService -- * Re-exported data constructors from /Foreign.C/ -- | Re-exports are needed by exporters for marshalling in foreign calls. ,Foreign.C.Types.CInt (..) ,Foreign.C.Types.CUInt (..) ) where import NgxExport import NgxExport.Tools.Read import NgxExport.Tools.System import NgxExport.Tools.TimeInterval import NgxExport.Tools.Types (NgxExportService) import Language.Haskell.TH import Foreign.C.Types import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import Data.IORef import Data.Maybe import Control.Monad import Control.Arrow import Control.Exception import System.IO.Unsafe (unsafePerformIO) -- $description -- -- This module implements a number of exporters for /simple services/. Here -- /simplicity/ means avoiding boilerplate code regarding to efficient reading -- of typed configurations and timed restarts of services. -- -- All simple services are classified as /untyped/ or /typed/. The untyped -- services have type -- -- @ -- 'ByteString' -> 'Prelude.Bool' -> 'IO' 'L.ByteString' -- @ -- -- which corresponds to the type of usual services from module "NgxExport". The -- typed services are backed by functions from module "NgxExport.Tools.Read" -- and may have two different types: -- -- @ -- 'Read' a => a -> 'Prelude.Bool' -> 'IO' 'L.ByteString' -- @ -- @ -- t'Data.Aeson.FromJSON' a => a -> 'Prelude.Bool' -> 'IO' 'L.ByteString' -- @ -- -- The choice of a certain type of a typed service depends on the format in -- which the typed data will be passed from the Nginx configuration. -- -- Below is a simple example. -- -- ==== File /test_tools.hs/ -- @ -- {-\# LANGUAGE TemplateHaskell, DeriveGeneric, RecordWildCards \#-} -- -- module TestTools where -- -- import NgxExport -- import NgxExport.Tools -- -- import Data.ByteString (ByteString) -- import qualified Data.ByteString.Lazy as L -- import qualified Data.ByteString.Lazy.Char8 as C8L -- import Data.Aeson -- import Data.IORef -- import Control.Monad -- import GHC.Generics -- -- test :: ByteString -> Bool -> IO L.ByteString -- __/test/__ = const . return . L.fromStrict -- 'ngxExportSimpleService' \'test $ -- 'PersistentService' $ Just $ 'Sec' 10 -- -- showAsLazyByteString :: Show a => a -> L.ByteString -- showAsLazyByteString = C8L.pack . show -- -- testRead :: Show a => a -> IO L.ByteString -- testRead = return . showAsLazyByteString -- -- testReadInt :: Int -> Bool -> IO L.ByteString -- __/testReadInt/__ = const . testRead -- 'ngxExportSimpleServiceTyped' \'testReadInt \'\'Int $ -- 'PersistentService' $ Just $ 'Sec' 10 -- -- newtype Conf = Conf Int deriving (Read, Show) -- -- testReadConf :: Conf -> Bool -> IO L.ByteString -- __/testReadConf/__ = const . testRead -- 'ngxExportSimpleServiceTyped' \'testReadConf \'\'Conf $ -- 'PersistentService' $ Just $ 'Sec' 10 -- -- testConfStorage :: ByteString -> IO L.ByteString -- __/testConfStorage/__ = const $ -- showAsLazyByteString \<$\> readIORef __/storage_Conf_testReadConf/__ -- 'ngxExportIOYY' \'testConfStorage -- -- data ConfWithDelay = ConfWithDelay { delay :: 'TimeInterval' -- , value :: Int -- } deriving (Read, Show) -- -- testReadConfWithDelay :: ConfWithDelay -> Bool -> IO L.ByteString -- __/testReadConfWithDelay/__ c\@ConfWithDelay {..} fstRun = do -- unless fstRun $ 'threadDelaySec' $ 'toSec' delay -- testRead c -- 'ngxExportSimpleServiceTyped' \'testReadConfWithDelay \'\'ConfWithDelay $ -- 'PersistentService' Nothing -- -- data ConfJSON = ConfJSONCon1 Int -- | ConfJSONCon2 deriving (Generic, Show) -- instance FromJSON ConfJSON -- -- testReadConfJSON :: ConfJSON -> Bool -> IO L.ByteString -- __/testReadConfJSON/__ = 'NgxExport.Tools.SplitService.ignitionService' testRead -- 'ngxExportSimpleServiceTypedAsJSON' \'testReadConfJSON \'\'ConfJSON -- 'SingleShotService' -- @ -- -- Here five simple services of various types are defined: /test/, -- /testReadInt/, /testReadConf/, /testReadConfWithDelay/, and -- /testReadConfJSON/. /Typed/ services hold 'IORef' /storages/ to save their -- configurations for faster access in future iterations. The name of a storage -- consists of the name of its type and the name of the service connected by an -- underscore and prefixed as a whole word with __/storage_/__. -- -- As soon as all the services in the example merely echo their configurations -- 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'@) -- -- In this toy example the most efficient sleeping strategy is a single-shot -- service because data is not altered during runtime. A single-shot service -- runs exactly two times during the lifetime of a worker process: the first -- run (when the second argument of the service, i.e. the /first-run/ flag, is -- /True/) is immediately followed by the second run (when the /first-run/ flag -- is /False/). On the second run the service handler is used as an exception -- handler when the service is shutting down after the 'WorkerProcessIsExiting' -- exception has been thrown. Accordingly, a single-shot handler can be used -- for allocation of some global resources (when the first-run flag is /True/), -- and cleaning them up (when the first-run flag is /False/). -- -- Notice that service /testReadConfWithDelay/ manages time delays on its own, -- therefore it uses /no-sleeps/ strategy @'PersistentService' Nothing@. -- -- ==== File /nginx.conf/ -- @ -- user nobody; -- worker_processes 2; -- -- events { -- worker_connections 1024; -- } -- -- http { -- default_type application\/octet-stream; -- sendfile on; -- -- haskell load \/var\/lib\/nginx\/test_tools.so; -- -- haskell_run_service __/simpleService_test/__ -- $hs_test -- test; -- -- haskell_run_service __/simpleService_testReadInt/__ -- $hs_testReadInt -- 5000000; -- -- haskell_run_service __/simpleService_testReadConf/__ -- $hs_testReadConf -- \'Conf 20\'; -- -- haskell_run_service __/simpleService_testReadConfWithDelay/__ -- $hs_testReadConfWithDelay -- \'ConfWithDelay { delay = Sec 10, value = 12 }\'; -- -- haskell_run_service __/simpleService_testReadConfJSON/__ -- $hs_testReadConfJSON -- \'{\"tag\":\"ConfJSONCon1\", \"contents\":56}\'; -- -- server { -- listen 8010; -- server_name main; -- error_log \/tmp\/nginx-test-haskell-error.log; -- access_log \/tmp\/nginx-test-haskell-access.log; -- -- location \/ { -- haskell_run __/testConfStorage/__ $hs_testConfStorage \'\'; -- -- echo \"Service variables:\"; -- echo \" hs_test: $hs_test\"; -- echo \" hs_testReadInt: $hs_testReadInt\"; -- echo \" hs_testReadConf: $hs_testReadConf\"; -- echo \" hs_testReadConfWithDelay: $hs_testReadConfWithDelay\"; -- echo \" hs_testReadConfJSON: $hs_testReadConfJSON\"; -- echo \"Storages of service variables:\"; -- echo \" hs_testConfStorage: $hs_testConfStorage\"; -- } -- } -- } -- @ -- -- Notice that Haskel handlers defined in /test_tools.hs/ are referred from -- the Nginx configuration file with prefix __/simpleService_/__. -- -- ==== A simple test -- > $ curl 'http://localhost:8010/' -- > Service variables: -- > hs_test: test -- > hs_testReadInt: 5000000 -- > hs_testReadConf: Conf 20 -- > hs_testReadConfWithDelay: ConfWithDelay {delay = Sec 10, value = 12} -- > hs_testReadConfJSON: ConfJSONCon1 56 -- > Storages of service variables: -- > hs_testConfStorage: Just (Conf 20) -- -- $preload -- -- Storages of typed simple services can be preloaded /synchronously/ with -- 'ngxExportInitHook'. This is useful if a storage gets accessed immediately -- after the start of processing client requests in a request handler which -- expects that the storage has already been initialized (for example, a request -- handler may unpack the storage with 'fromJust' without checking errors). -- -- ==== File /test_tools.hs/: preload storage_Int_testReadInt -- @ -- import System.Environment -- -- -- ... -- -- initTestReadInt :: IO () -- __/initTestReadInt/__ = do -- _ : v : _ \<- dropWhile (\/= \"__/--testReadInt/__\") \<$\> 'System.Environment.getArgs' -- let i = read v -- i \`seq\` writeIORef __/storage_Int_testReadInt/__ (Just i) -- 'ngxExportInitHook' \'initTestReadInt -- @ -- -- Note that the preloaded value gets evaluated inside the hook to spot any -- parse errors inplace before the start of processing client requests. -- -- ==== File /nginx.conf/: read data for storage_Int_testReadInt -- @ -- haskell program_options __/--testReadInt/__ 800; -- -- # ... -- -- haskell_run_service __/simpleService_testReadInt/__ -- $hs_testReadInt -- __/-/__; -- @ -- -- The preloaded value gets passed in directive /haskell program_options/. The -- value in the service declaration can be replaced by any lexeme as it won't -- be parsed. In this example, it was replaced by a dash. -- | Defines a sleeping strategy. data ServiceMode -- | Persistent service (with or without periodical sleeps) = PersistentService (Maybe TimeInterval) -- | Single-shot service | SingleShotService ngxExportSimpleService' :: Name -> Maybe (Name, Bool) -> ServiceMode -> Q [Dec] ngxExportSimpleService' f c m = do confBs <- newName "confBs_" fstRun <- newName "fstRun_" let nameF = nameBase f nameSsf = mkName $ "simpleService_" ++ nameF hasConf = isJust c (sNameC, typeC, readConf, unreadableConfMsg) = if hasConf then let ((tName, tNameBase), isJSON) = first (id &&& nameBase) $ fromJust c in (mkName $ "storage_" ++ tNameBase ++ '_' : nameF ,conT tName ,if isJSON then [|readFromByteStringAsJSON|] else [|readFromByteString|] ,"Configuration " ++ tNameBase ++ " is not readable" ) else undefined initConf = let eConfBs = varE confBs in if hasConf then let storage = varE sNameC in [|readIORef $(storage) >>= maybe (do let conf_data__ = $(readConf) $(eConfBs) when (isNothing conf_data__) $ terminateWorkerProcess unreadableConfMsg writeIORef $(storage) conf_data__ return conf_data__ ) (return . Just) |] else [|return $ Just $(eConfBs)|] (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 |] ) 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_ <- fromJust <$> $(initConf) $(waitTime) conf_data_ $(runService) conf_data_ |] ) [] ] ] ,ngxExportServiceIOYY nameSsf ] -- | Exports a simple service of type -- -- @ -- 'ByteString' -> 'Prelude.Bool' -> 'IO' 'L.ByteString' -- @ -- -- with specified name and service mode. ngxExportSimpleService :: Name -- ^ Name of the service -> ServiceMode -- ^ Service mode -> Q [Dec] ngxExportSimpleService f = ngxExportSimpleService' f Nothing -- | Exports a simple service of type -- -- @ -- 'Read' a => a -> 'Prelude.Bool' -> 'IO' 'L.ByteString' -- @ -- -- with specified name and service mode. -- -- The service expects an object of a custom type implementing an instance of -- 'Read' at 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. The storage can be accessed -- from elsewhere by a name comprised of the name of the custom type and the -- name of the service connected by an underscore and prefixed as a whole word -- with __/storage_/__. The stored data is wrapped in a 'Maybe' container which -- contains 'Nothing' until the initialization on the first service run. -- -- When reading of the custom object fails on the first service run, the -- service terminates the worker process by calling 'terminateWorkerProcess' -- with a corresponding message. ngxExportSimpleServiceTyped :: Name -- ^ Name of the service -> Name -- ^ Name of the custom type -> ServiceMode -- ^ Service mode -> Q [Dec] ngxExportSimpleServiceTyped f c = ngxExportSimpleService' f $ Just (c, False) -- | Exports a simple service of type -- -- @ -- t'Data.Aeson.FromJSON' a => a -> 'Prelude.Bool' -> 'IO' 'L.ByteString' -- @ -- -- with specified name and service mode. -- -- The service expects an object of a custom type implementing an instance of -- t'Data.Aeson.FromJSON' at 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. The storage -- can be accessed from elsewhere by a name comprised of the name of the custom -- type and the name of the service connected by an underscore and prefixed as a -- whole word with __/storage_/__. The stored data is wrapped in a 'Maybe' -- container which contains 'Nothing' until the initialization on the first -- service run. -- -- When reading of the custom object fails on the first service run, the -- service terminates the worker process by calling 'terminateWorkerProcess' -- with a corresponding message. ngxExportSimpleServiceTypedAsJSON :: Name -- ^ Name of the service -> Name -- ^ Name of the custom type -> ServiceMode -- ^ Service mode -> Q [Dec] ngxExportSimpleServiceTypedAsJSON f c = ngxExportSimpleService' f $ Just (c, True)