{-# LANGUAGE TemplateHaskell, TypeFamilies, EmptyDataDecls #-} {-# LANGUAGE DeriveGeneric, DeriveLift, NumDecimals #-} ----------------------------------------------------------------------------- -- | -- Module : NgxExport.Tools -- Copyright : (c) Alexey Radkov 2018-2019 -- License : BSD-style -- -- Maintainer : alexey.radkov@gmail.com -- Stability : experimental -- Portability : non-portable (requires Template Haskell) -- -- Extra tools for using in custom Haskell code with -- <http://github.com/lyokha/nginx-haskell-module nginx-haskell-module>. -- ----------------------------------------------------------------------------- module NgxExport.Tools ( -- * Various useful functions and data terminateWorkerProcess ,restartWorkerProcess ,finalizeHTTPRequest ,workerProcessIsExiting ,ngxRequestPtr ,ngxNow ,ngxPid -- *** Time intervals ,TimeInterval (..) ,toSec ,threadDelaySec -- *** Reading custom types from /ByteStrings/ -- $readingCustomTypes ,readFromByteString ,readFromByteStringAsJSON ,readFromByteStringWithRPtr ,readFromByteStringWithRPtrAsJSON ,skipRPtr -- * Exporters of simple services -- $simpleServices ,ServiceMode (..) ,ngxExportSimpleService ,ngxExportSimpleServiceTyped ,ngxExportSimpleServiceTypedAsJSON -- * Split services -- $splitServices ,splitService ,ignitionService ,deferredService -- * 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 Language.Haskell.TH import Language.Haskell.TH.Syntax import Foreign.Ptr import Foreign.Storable import Foreign.C.Types import qualified Data.ByteString as B import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L import Data.Binary.Get import Data.IORef import Data.Maybe import Data.Aeson import Data.Function (on) import Data.Ord (comparing) import Control.Monad import Control.Arrow import Control.Exception import Control.Concurrent import GHC.Generics import System.IO.Unsafe (unsafePerformIO) import System.Posix.Types import Safe -- | Terminates the Nginx worker process from a Haskell service. -- -- Nginx master process shall /not/ spawn a new worker process thereafter. This -- function throws exception 'TerminateWorkerProcess', and therefore terminates -- the worker process effectively only from a Haskell service. terminateWorkerProcess :: String -> IO () terminateWorkerProcess :: String -> IO () terminateWorkerProcess = TerminateWorkerProcess -> IO () forall e a. Exception e => e -> IO a throwIO (TerminateWorkerProcess -> IO ()) -> (String -> TerminateWorkerProcess) -> String -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> TerminateWorkerProcess TerminateWorkerProcess -- | Restarts the Nginx worker process from a Haskell service. -- -- Nginx master process shall spawn a new worker process after termination of -- the current one. This function throws exception 'RestartWorkerProcess', and -- therefore terminates the worker process effectively only from a Haskell -- service. restartWorkerProcess :: String -> IO () restartWorkerProcess :: String -> IO () restartWorkerProcess = RestartWorkerProcess -> IO () forall e a. Exception e => e -> IO a throwIO (RestartWorkerProcess -> IO ()) -> (String -> RestartWorkerProcess) -> String -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> RestartWorkerProcess RestartWorkerProcess -- | Finalizes the current HTTP request from a Haskell asynchronous variable -- handler. -- -- This function throws exception 'FinalizeHTTPRequest', and therefore -- terminates the HTTP request effectively only from a Haskell asynchronous -- variable handler. finalizeHTTPRequest :: Int -> Maybe String -> IO () finalizeHTTPRequest :: Int -> Maybe String -> IO () finalizeHTTPRequest = (FinalizeHTTPRequest -> IO () forall e a. Exception e => e -> IO a throwIO (FinalizeHTTPRequest -> IO ()) -> (Maybe String -> FinalizeHTTPRequest) -> Maybe String -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c .) ((Maybe String -> FinalizeHTTPRequest) -> Maybe String -> IO ()) -> (Int -> Maybe String -> FinalizeHTTPRequest) -> Int -> Maybe String -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> Maybe String -> FinalizeHTTPRequest FinalizeHTTPRequest -- | Checks that a generic exception is of type 'WorkerProcessIsExiting'. -- -- This can be useful to check quickly in an exception handler whether a -- Haskell service has been interrupted because the worker process is exiting. workerProcessIsExiting :: SomeException -> Bool workerProcessIsExiting :: SomeException -> Bool workerProcessIsExiting e :: SomeException e = Maybe WorkerProcessIsExiting -> Bool forall a. Maybe a -> Bool isJust (SomeException -> Maybe WorkerProcessIsExiting forall e. Exception e => SomeException -> Maybe e fromException SomeException e :: Maybe WorkerProcessIsExiting) -- | Unmarshals the value of Nginx variable __/$_r_ptr/__ into a pointer to -- the Nginx request object. -- -- This is safe to use in request-based Haskell handlers such as synchronous -- and asynchronous tasks and content handlers, but not in services and their -- derivatives. In /asynchronous/ tasks and content handlers the value must be -- used as read-only. The value can be passed into a /C plugin/, however, as -- opposed to usual functions in Nginx C code, it must be tested against the -- /NULL/ value. ngxRequestPtr :: ByteString -> Ptr () ngxRequestPtr :: ByteString -> Ptr () ngxRequestPtr = WordPtr -> Ptr () forall a. WordPtr -> Ptr a wordPtrToPtr (WordPtr -> Ptr ()) -> (ByteString -> WordPtr) -> ByteString -> Ptr () forall b c a. (b -> c) -> (a -> b) -> a -> c . Word -> WordPtr forall a b. (Integral a, Num b) => a -> b fromIntegral (Word -> WordPtr) -> (ByteString -> Word) -> ByteString -> WordPtr forall b c a. (b -> c) -> (a -> b) -> a -> c . Get Word -> ByteString -> Word forall a. Get a -> ByteString -> a runGet Get Word getWordhost (ByteString -> Word) -> (ByteString -> ByteString) -> ByteString -> Word forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString L.fromStrict -- | Returns the current time as the number of seconds elapsed since the UNIX -- epoch. -- -- The value is taken from Nginx core, so no additional system calls get -- involved. On the other hand, it means that this is only safe to use from -- an Nginx worker's main thread, i.e. in /synchronous/ Haskell handlers and -- /service hooks/. Be also aware that this is a small type casting hack: -- the value is interpreted as being of type @time_t@ while having been -- actually wrapped in a bigger C struct as its first element. ngxNow :: IO CTime ngxNow :: IO CTime ngxNow = IO (Ptr (Ptr ())) ngxCachedTimePtr IO (Ptr (Ptr ())) -> (Ptr (Ptr ()) -> IO (Ptr ())) -> IO (Ptr ()) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Ptr (Ptr ()) -> IO (Ptr ()) forall a. Storable a => Ptr a -> IO a peek IO (Ptr ()) -> (Ptr () -> IO CTime) -> IO CTime forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Ptr CTime -> IO CTime forall a. Storable a => Ptr a -> IO a peek (Ptr CTime -> IO CTime) -> (Ptr () -> Ptr CTime) -> Ptr () -> IO CTime forall b c a. (b -> c) -> (a -> b) -> a -> c . Ptr () -> Ptr CTime forall a b. Ptr a -> Ptr b castPtr -- | Returns the /PID/ of the current worker process cached in Nginx core. ngxPid :: IO CPid ngxPid :: IO CPid ngxPid = IO CPid ngxCachedPid -- | Time intervals. data TimeInterval = Hr Int -- ^ Hours | Min Int -- ^ Minutes | Sec Int -- ^ Seconds | HrMin Int Int -- ^ Hours and minutes | MinSec Int Int -- ^ Minutes and seconds | Unset -- ^ Zero time interval, equal to @Sec 0@ deriving ((forall x. TimeInterval -> Rep TimeInterval x) -> (forall x. Rep TimeInterval x -> TimeInterval) -> Generic TimeInterval forall x. Rep TimeInterval x -> TimeInterval forall x. TimeInterval -> Rep TimeInterval x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep TimeInterval x -> TimeInterval $cfrom :: forall x. TimeInterval -> Rep TimeInterval x Generic, TimeInterval -> Q Exp (TimeInterval -> Q Exp) -> Lift TimeInterval forall t. (t -> Q Exp) -> Lift t lift :: TimeInterval -> Q Exp $clift :: TimeInterval -> Q Exp Lift, ReadPrec [TimeInterval] ReadPrec TimeInterval Int -> ReadS TimeInterval ReadS [TimeInterval] (Int -> ReadS TimeInterval) -> ReadS [TimeInterval] -> ReadPrec TimeInterval -> ReadPrec [TimeInterval] -> Read TimeInterval forall a. (Int -> ReadS a) -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a readListPrec :: ReadPrec [TimeInterval] $creadListPrec :: ReadPrec [TimeInterval] readPrec :: ReadPrec TimeInterval $creadPrec :: ReadPrec TimeInterval readList :: ReadS [TimeInterval] $creadList :: ReadS [TimeInterval] readsPrec :: Int -> ReadS TimeInterval $creadsPrec :: Int -> ReadS TimeInterval Read, Int -> TimeInterval -> ShowS [TimeInterval] -> ShowS TimeInterval -> String (Int -> TimeInterval -> ShowS) -> (TimeInterval -> String) -> ([TimeInterval] -> ShowS) -> Show TimeInterval forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TimeInterval] -> ShowS $cshowList :: [TimeInterval] -> ShowS show :: TimeInterval -> String $cshow :: TimeInterval -> String showsPrec :: Int -> TimeInterval -> ShowS $cshowsPrec :: Int -> TimeInterval -> ShowS Show) instance FromJSON TimeInterval instance Eq TimeInterval where == :: TimeInterval -> TimeInterval -> Bool (==) = Int -> Int -> Bool forall a. Eq a => a -> a -> Bool (==) (Int -> Int -> Bool) -> (TimeInterval -> Int) -> TimeInterval -> TimeInterval -> Bool forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c `on` TimeInterval -> Int toSec instance Ord TimeInterval where compare :: TimeInterval -> TimeInterval -> Ordering compare = (TimeInterval -> Int) -> TimeInterval -> TimeInterval -> Ordering forall a b. Ord a => (b -> a) -> b -> b -> Ordering comparing TimeInterval -> Int toSec -- | Converts a time interval into seconds. toSec :: TimeInterval -> Int toSec :: TimeInterval -> Int toSec (Hr h :: Int h) = 3600 Int -> Int -> Int forall a. Num a => a -> a -> a * Int h toSec (Min m :: Int m) = 60 Int -> Int -> Int forall a. Num a => a -> a -> a * Int m toSec (Sec s :: Int s) = Int s toSec (HrMin h :: Int h m :: Int m) = 3600 Int -> Int -> Int forall a. Num a => a -> a -> a * Int h Int -> Int -> Int forall a. Num a => a -> a -> a + 60 Int -> Int -> Int forall a. Num a => a -> a -> a * Int m toSec (MinSec m :: Int m s :: Int s) = 60 Int -> Int -> Int forall a. Num a => a -> a -> a * Int m Int -> Int -> Int forall a. Num a => a -> a -> a + Int s toSec Unset = 0 -- | Delays the current thread by the specified number of seconds. threadDelaySec :: Int -> IO () threadDelaySec :: Int -> IO () threadDelaySec = Int -> IO () threadDelay (Int -> IO ()) -> (Int -> Int) -> Int -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . (Int -> Int -> Int forall a. Num a => a -> a -> a * 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 :: Maybe (Readable a) -> ByteString -> Maybe (WrappedT (Readable a)) fromByteString = (ByteString -> Maybe a) -> Maybe (Readable a) -> ByteString -> Maybe (WrappedT (Readable a)) forall a b. a -> b -> a const ((ByteString -> Maybe a) -> Maybe (Readable a) -> ByteString -> Maybe (WrappedT (Readable a))) -> (ByteString -> Maybe a) -> Maybe (Readable a) -> ByteString -> Maybe (WrappedT (Readable a)) forall a b. (a -> b) -> a -> b $ String -> Maybe a forall a. Read a => String -> Maybe a readMay (String -> Maybe a) -> (ByteString -> String) -> ByteString -> Maybe a forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> String C8.unpack instance FromJSON a => FromByteString (ReadableAsJSON a) where type WrappedT (ReadableAsJSON a) = a fromByteString :: Maybe (ReadableAsJSON a) -> ByteString -> Maybe (WrappedT (ReadableAsJSON a)) fromByteString = (ByteString -> Maybe a) -> Maybe (ReadableAsJSON a) -> ByteString -> Maybe a forall a b. a -> b -> a const ByteString -> Maybe a forall a. FromJSON a => ByteString -> Maybe a decodeStrict instance FromByteString ByteString where type WrappedT ByteString = ByteString fromByteString :: Maybe ByteString -> ByteString -> Maybe (WrappedT ByteString) fromByteString = (ByteString -> Maybe ByteString) -> Maybe ByteString -> ByteString -> Maybe ByteString forall a b. a -> b -> a const ByteString -> Maybe ByteString forall a. a -> Maybe a Just -- $readingCustomTypes -- -- There are a number of functions to support /typed/ exchange between Nginx -- and Haskell handlers. Functions 'readFromByteString' and -- 'readFromByteStringAsJSON' expect serialized values of custom types deriving -- or implementing instances of 'Read' and 'FromJSON' respectively. Functions -- 'readFromByteStringWithRPtr' and 'readFromByteStringWithRPtrAsJSON' -- additionally expect a binary value of a C pointer size marshalled in front -- of the value of the custom type. This pointer should correspond to the value -- of Nginx variable __/$_r_ptr/__. -- -- Below is a toy example. -- -- ==== File /test_tools.hs/ -- @ -- {-\# LANGUAGE TemplateHaskell, DeriveGeneric, TypeApplications \#-} -- -- 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 GHC.Generics -- -- showAsLazyByteString :: Show a => a -> L.ByteString -- showAsLazyByteString = C8L.pack . show -- -- newtype Conf = Conf Int deriving (Read, Show) -- -- data ConfJSON = ConfJSONCon1 Int -- | ConfJSONCon2 deriving (Generic, Show) -- instance FromJSON ConfJSON -- -- testReadIntHandler :: ByteString -> L.ByteString -- __/testReadIntHandler/__ = showAsLazyByteString . -- 'readFromByteString' \@Int -- 'ngxExportYY' \'testReadIntHandler -- -- testReadConfHandler :: ByteString -> L.ByteString -- __/testReadConfHandler/__ = showAsLazyByteString . -- 'readFromByteString' \@Conf -- 'ngxExportYY' \'testReadConfHandler -- -- testReadConfJSONHandler :: ByteString -> IO L.ByteString -- __/testReadConfJSONHandler/__ = return . showAsLazyByteString . -- 'readFromByteStringAsJSON' \@ConfJSON -- 'ngxExportAsyncIOYY' \'testReadConfJSONHandler -- -- testReadConfWithRPtrHandler :: ByteString -> L.ByteString -- __/testReadConfWithRPtrHandler/__ = showAsLazyByteString . -- 'readFromByteStringWithRPtr' \@Conf -- 'ngxExportYY' \'testReadConfWithRPtrHandler -- -- testReadConfWithRPtrJSONHandler :: ByteString -> L.ByteString -- __/testReadConfWithRPtrJSONHandler/__ = showAsLazyByteString . -- 'readFromByteStringWithRPtrAsJSON' \@ConfJSON -- 'ngxExportYY' \'testReadConfWithRPtrJSONHandler -- @ -- -- Here five Haskell handlers are defined: /testReadIntHandler/, -- /testReadConfHandler/, /testReadConfJSONHandler/, -- /testReadConfWithRPtrHandler/, and /testReadConfWithRPtrJSONHandler/. Four -- of them are /synchronous/ and one is /asynchronous/ for the sake of variety. -- -- ==== 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; -- -- 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 __/testReadIntHandler/__ -- $hs_testReadIntHandler -- -456; -- haskell_run __/testReadConfHandler/__ -- $hs_testReadConfHandler -- \'Conf 21\'; -- haskell_run_async __/testReadConfJSONHandler/__ -- $hs_testReadConfJSONHandler -- \'{\"tag\":\"ConfJSONCon2\"}\'; -- haskell_run_async __/testReadConfJSONHandler/__ -- $hs_testReadConfJSONHandlerBadInput -- \'{\"tag\":\"Unknown\"}\'; -- haskell_run __/testReadConfWithRPtrHandler/__ -- $hs_testReadConfWithRPtrHandler -- \'${_r_ptr}Conf 21\'; -- haskell_run __/testReadConfWithRPtrJSONHandler/__ -- $hs_testReadConfWithRPtrJSONHandler -- \'$_r_ptr -- {\"tag\":\"ConfJSONCon1\", \"contents\":4} -- \'; -- -- echo \"Handler variables:\"; -- echo \" hs_testReadIntHandler: $hs_testReadIntHandler\"; -- echo \" hs_testReadConfHandler: $hs_testReadConfHandler\"; -- echo \" hs_testReadConfJSONHandler: $hs_testReadConfJSONHandler\"; -- echo \" hs_testReadConfJSONHandlerBadInput: $hs_testReadConfJSONHandlerBadInput\"; -- echo \" hs_testReadConfWithRPtrHandler: $hs_testReadConfWithRPtrHandler\"; -- echo \" hs_testReadConfWithRPtrJSONHandler: $hs_testReadConfWithRPtrJSONHandler\"; -- } -- } -- } -- @ -- -- ==== A simple test -- > $ curl 'http://localhost:8010/' -- > Handler variables: -- > hs_testReadIntHandler: Just (-456) -- > hs_testReadConfHandler: Just (Conf 21) -- > hs_testReadConfJSONHandler: Just ConfJSONCon2 -- > hs_testReadConfJSONHandlerBadInput: Nothing -- > hs_testReadConfWithRPtrHandler: (0x00000000016fc790,Just (Conf 21)) -- > hs_testReadConfWithRPtrJSONHandler: (0x00000000016fc790,Just (ConfJSONCon1 4)) -- | Reads an object of a custom type implementing an instance of 'Read' -- from a 'ByteString'. -- -- Returns 'Nothing' if reading fails. readFromByteString :: Read a => ByteString -> Maybe a readFromByteString :: ByteString -> Maybe a readFromByteString = Maybe (Readable a) -> ByteString -> Maybe (WrappedT (Readable a)) forall a. FromByteString a => Maybe a -> ByteString -> Maybe (WrappedT a) fromByteString (forall a. Maybe a forall a. Maybe (Readable a) Nothing :: Maybe (Readable a)) -- | Reads an object of a custom type implementing an instance of 'FromJSON' -- from a 'ByteString'. -- -- Returns 'Nothing' if reading fails. readFromByteStringAsJSON :: FromJSON a => ByteString -> Maybe a readFromByteStringAsJSON :: ByteString -> Maybe a readFromByteStringAsJSON = Maybe (ReadableAsJSON a) -> ByteString -> Maybe (WrappedT (ReadableAsJSON a)) forall a. FromByteString a => Maybe a -> ByteString -> Maybe (WrappedT a) fromByteString (forall a. Maybe a forall a. Maybe (ReadableAsJSON a) Nothing :: Maybe (ReadableAsJSON a)) -- | Reads a pointer to the Nginx request object followed by an object of -- a custom type implementing an instance of 'Read' from a 'ByteString'. -- -- Throws an exception if unmarshalling of the request pointer fails. In the -- second element of the tuple returns 'Nothing' if reading of the custom -- object fails. Notice that the value of the returned request pointer is not -- checked against /NULL/. readFromByteStringWithRPtr :: Read a => ByteString -> (Ptr (), Maybe a) readFromByteStringWithRPtr :: ByteString -> (Ptr (), Maybe a) readFromByteStringWithRPtr = ByteString -> Ptr () ngxRequestPtr (ByteString -> Ptr ()) -> (ByteString -> Maybe a) -> ByteString -> (Ptr (), Maybe a) forall (a :: * -> * -> *) b c c'. Arrow a => a b c -> a b c' -> a b (c, c') &&& ByteString -> Maybe a forall a. Read a => ByteString -> Maybe a readFromByteString (ByteString -> Maybe a) -> (ByteString -> ByteString) -> ByteString -> Maybe a forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString skipRPtr -- | Reads a pointer to the Nginx request object followed by an object of -- a custom type implementing an instance of 'FromJSON' from a 'ByteString'. -- -- Throws an exception if unmarshalling of the request pointer fails. In the -- second element of the tuple returns 'Nothing' if decoding of the custom -- object fails. Notice that the value of the returned request pointer is not -- checked against /NULL/. readFromByteStringWithRPtrAsJSON :: FromJSON a => ByteString -> (Ptr (), Maybe a) readFromByteStringWithRPtrAsJSON :: ByteString -> (Ptr (), Maybe a) readFromByteStringWithRPtrAsJSON = ByteString -> Ptr () ngxRequestPtr (ByteString -> Ptr ()) -> (ByteString -> Maybe a) -> ByteString -> (Ptr (), Maybe a) forall (a :: * -> * -> *) b c c'. Arrow a => a b c -> a b c' -> a b (c, c') &&& ByteString -> Maybe a forall a. FromJSON a => ByteString -> Maybe a readFromByteStringAsJSON (ByteString -> Maybe a) -> (ByteString -> ByteString) -> ByteString -> Maybe a forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString skipRPtr -- | Skips the number of bytes equal to the size of a pointer from the beginning -- of a 'ByteString'. -- -- This can be useful to drop a pointer to the Nginx request object passed at -- the beginning of a handler's argument. skipRPtr :: ByteString -> ByteString skipRPtr :: ByteString -> ByteString skipRPtr = Int -> ByteString -> ByteString B.drop (Int -> ByteString -> ByteString) -> Int -> ByteString -> ByteString forall a b. (a -> b) -> a -> b $ Word -> Int forall a. Storable a => a -> Int sizeOf (Word forall a. HasCallStack => a undefined :: Word) -- $simpleServices -- -- There are 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 have type -- -- @ -- 'ByteString' -> 'Prelude.Bool' -> 'IO' 'L.ByteString' -- @ -- -- which corresponds to the type of usual services from module "NgxExport". -- -- Below is a toy 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/__ = '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) -- | 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' :: Name -> Maybe (Name, Bool) -> ServiceMode -> Q [Dec] ngxExportSimpleService' f :: Name f c :: Maybe (Name, Bool) c m :: ServiceMode m = do Name confBs <- String -> Q Name newName "confBs_" Name fstRun <- String -> Q Name newName "fstRun_" let nameF :: String nameF = Name -> String nameBase Name f nameSsf :: Name nameSsf = String -> Name mkName (String -> Name) -> String -> Name forall a b. (a -> b) -> a -> b $ "simpleService_" String -> ShowS forall a. [a] -> [a] -> [a] ++ String nameF hasConf :: Bool hasConf = Maybe (Name, Bool) -> Bool forall a. Maybe a -> Bool isJust Maybe (Name, Bool) c (sNameC :: Name sNameC, typeC :: TypeQ typeC, readConf :: Q Exp readConf, unreadableConfMsg :: String unreadableConfMsg) = if Bool hasConf then let (tName :: String tName, isJSON :: Bool isJSON) = (Name -> String) -> (Name, Bool) -> (String, Bool) forall (a :: * -> * -> *) b c d. Arrow a => a b c -> a (b, d) (c, d) first Name -> String nameBase ((Name, Bool) -> (String, Bool)) -> (Name, Bool) -> (String, Bool) forall a b. (a -> b) -> a -> b $ Maybe (Name, Bool) -> (Name, Bool) forall a. HasCallStack => Maybe a -> a fromJust Maybe (Name, Bool) c in (String -> Name mkName (String -> Name) -> String -> Name forall a b. (a -> b) -> a -> b $ "storage_" String -> ShowS forall a. [a] -> [a] -> [a] ++ String tName String -> ShowS forall a. [a] -> [a] -> [a] ++ '_' Char -> ShowS forall a. a -> [a] -> [a] : String nameF -- FIXME: using base name of the type means that it is -- not possible to pass here qualified types from -- external modules. Using showName instead of nameBase -- won't help, as it adds static qualified names like -- GHC.Types.Int that can be unexpected in the context -- of the user's module scope, instead of adding the -- dynamic namespace (possibly not qualified) specified -- in the import clause of the user's module. ,Name -> TypeQ conT (Name -> TypeQ) -> Name -> TypeQ forall a b. (a -> b) -> a -> b $ String -> Name mkName String tName ,if Bool isJSON then [|readFromByteStringAsJSON|] else [|readFromByteString|] ,"Configuration " String -> ShowS forall a. [a] -> [a] -> [a] ++ String tName String -> ShowS forall a. [a] -> [a] -> [a] ++ " is not readable" ) else (Name, TypeQ, Q Exp, String) forall a. HasCallStack => a undefined initConf :: Q Exp initConf = let eConfBs :: Q Exp eConfBs = Name -> Q Exp varE Name confBs in if Bool hasConf then let storage :: Q Exp storage = Name -> Q Exp varE Name 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 $ fromByteString (Nothing :: Maybe ByteString) $(eConfBs) |] (waitTime :: Q Exp waitTime, runService :: Q Exp runService) = let eF :: Q Exp eF = Name -> Q Exp varE Name f eFstRun :: Q Exp eFstRun = Name -> Q Exp varE Name fstRun runPersistentService :: Q Exp runPersistentService = [|flip $(eF) $(eFstRun)|] in case ServiceMode m of PersistentService (Just t :: TimeInterval t) -> ([|const $ unless $(eFstRun) $ threadDelaySec $ toSec t|] ,Q Exp runPersistentService ) PersistentService Nothing -> ([|const $ return ()|] ,Q Exp 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 |] ) [[Dec]] -> [Dec] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Q [Dec]] -> Q [[Dec]] forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [[Q Dec] -> Q [Dec] forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec] forall a b. (a -> b) -> a -> b $ (if Bool hasConf then [Name -> TypeQ -> Q Dec sigD Name sNameC [t|IORef (Maybe $(typeC))|] ,Name -> [ClauseQ] -> Q Dec funD Name sNameC [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ clause [] (Q Exp -> BodyQ normalB [|unsafePerformIO $ newIORef Nothing|]) [] ] ,Name -> Inline -> RuleMatch -> Phases -> Q Dec pragInlD Name sNameC Inline NoInline RuleMatch FunLike Phases AllPhases ] else [] ) [Q Dec] -> [Q Dec] -> [Q Dec] forall a. [a] -> [a] -> [a] ++ [Name -> TypeQ -> Q Dec sigD Name nameSsf [t|ByteString -> Bool -> IO L.ByteString|] ,Name -> [ClauseQ] -> Q Dec funD Name nameSsf [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ clause [Name -> PatQ varP Name confBs, Name -> PatQ varP Name fstRun] (Q Exp -> BodyQ normalB [|do conf_data_ <- fromJust <$> $(initConf) $(waitTime) conf_data_ $(runService) conf_data_ |] ) [] ] ] ,Name -> Q [Dec] ngxExportServiceIOYY Name 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 :: Name -> ServiceMode -> Q [Dec] ngxExportSimpleService f :: Name f = Name -> Maybe (Name, Bool) -> ServiceMode -> Q [Dec] ngxExportSimpleService' Name f Maybe (Name, Bool) forall a. Maybe a 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 'Maybe' container. -- -- 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 :: Name -> Name -> ServiceMode -> Q [Dec] ngxExportSimpleServiceTyped f :: Name f c :: Name c = Name -> Maybe (Name, Bool) -> ServiceMode -> Q [Dec] ngxExportSimpleService' Name f (Maybe (Name, Bool) -> ServiceMode -> Q [Dec]) -> Maybe (Name, Bool) -> ServiceMode -> Q [Dec] forall a b. (a -> b) -> a -> b $ (Name, Bool) -> Maybe (Name, Bool) forall a. a -> Maybe a Just (Name c, Bool False) -- | Exports a simple service of type -- -- @ -- '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 -- '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 'Maybe' -- container. -- -- 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 :: Name -> Name -> ServiceMode -> Q [Dec] ngxExportSimpleServiceTypedAsJSON f :: Name f c :: Name c = Name -> Maybe (Name, Bool) -> ServiceMode -> Q [Dec] ngxExportSimpleService' Name f (Maybe (Name, Bool) -> ServiceMode -> Q [Dec]) -> Maybe (Name, Bool) -> ServiceMode -> Q [Dec] forall a b. (a -> b) -> a -> b $ (Name, Bool) -> Maybe (Name, Bool) forall a. a -> Maybe a Just (Name c, Bool True) -- $splitServices -- -- Here are a number of combinators to facilitate creation of specialized -- services. They allow distinguishing between /ignition/ and /deferred/ -- services: the former run when the /first-run/ flag is /True/ whereas the -- latter run when the flag is /False/. The most promising use case for these -- helper functions is tuning of /single-shot/ services: in this case the -- ignition service corresponds to a normal single-shot action on startup of a -- worker process, while the deferred service corresponds to a cleanup handler -- and runs when a worker process exits. -- -- In all helpers, configuration and the first-run flag parameters belong to -- the common service signature, and therefore should not be bound by any -- arguments. -- | Sets two different actions as ignition and deferred services. -- -- When used as a single-shot service, the second action only runs on exit of a -- worker process, and therefore can be used as a cleanup handler. splitService :: (a -> IO L.ByteString) -- ^ Ignition service -> (a -> IO L.ByteString) -- ^ Deferred service -> a -- ^ Configuration -> Bool -- ^ First-run flag -> IO L.ByteString splitService :: (a -> IO ByteString) -> (a -> IO ByteString) -> a -> Bool -> IO ByteString splitService is :: a -> IO ByteString is ds :: a -> IO ByteString ds c :: a c fstRun :: Bool fstRun | Bool fstRun = a -> IO ByteString is a c | Bool otherwise = a -> IO ByteString ds a c -- | Sets an action as an ignition service. ignitionService :: (a -> IO L.ByteString) -- ^ Ignition service -> a -- ^ Configuration -> Bool -- ^ First-run flag -> IO L.ByteString ignitionService :: (a -> IO ByteString) -> a -> Bool -> IO ByteString ignitionService is :: a -> IO ByteString is = (a -> IO ByteString) -> (a -> IO ByteString) -> a -> Bool -> IO ByteString forall a. (a -> IO ByteString) -> (a -> IO ByteString) -> a -> Bool -> IO ByteString splitService a -> IO ByteString is ((a -> IO ByteString) -> a -> Bool -> IO ByteString) -> (a -> IO ByteString) -> a -> Bool -> IO ByteString forall a b. (a -> b) -> a -> b $ IO ByteString -> a -> IO ByteString forall a b. a -> b -> a const (IO ByteString -> a -> IO ByteString) -> IO ByteString -> a -> IO ByteString forall a b. (a -> b) -> a -> b $ ByteString -> IO ByteString forall (m :: * -> *) a. Monad m => a -> m a return ByteString L.empty -- | Sets an action as a deferred service. -- -- When used as a single-shot service, the action only runs on exit of a worker -- process, and therefore can be used as a cleanup handler. deferredService :: (a -> IO L.ByteString) -- ^ Deferred service -> a -- ^ Configuration -> Bool -- ^ First-run flag -> IO L.ByteString deferredService :: (a -> IO ByteString) -> a -> Bool -> IO ByteString deferredService = (a -> IO ByteString) -> (a -> IO ByteString) -> a -> Bool -> IO ByteString forall a. (a -> IO ByteString) -> (a -> IO ByteString) -> a -> Bool -> IO ByteString splitService ((a -> IO ByteString) -> (a -> IO ByteString) -> a -> Bool -> IO ByteString) -> (a -> IO ByteString) -> (a -> IO ByteString) -> a -> Bool -> IO ByteString forall a b. (a -> b) -> a -> b $ IO ByteString -> a -> IO ByteString forall a b. a -> b -> a const (IO ByteString -> a -> IO ByteString) -> IO ByteString -> a -> IO ByteString forall a b. (a -> b) -> a -> b $ ByteString -> IO ByteString forall (m :: * -> *) a. Monad m => a -> m a return ByteString L.empty