diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,4 @@ +### 0.1.0.0 + +- Initial version. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2016-2018, Alexey Radkov. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/NgxExport/Tools.hs b/NgxExport/Tools.hs new file mode 100644 --- /dev/null +++ b/NgxExport/Tools.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface, TypeFamilies #-} +{-# LANGUAGE DeriveGeneric, DeriveLift, NumDecimals #-} + +----------------------------------------------------------------------------- +-- | +-- Module : NgxExport.Tools +-- Copyright : (c) Alexey Radkov 2018 +-- 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 +-- . +-- +----------------------------------------------------------------------------- + + +module NgxExport.Tools ( + -- * Various useful functions and data + exitWorkerProcess + ,terminateWorkerProcess + ,ngxNow + ,threadDelaySec + ,TimeInterval (..) + ,toSec + -- * Exporters of simple services + -- + -- $simpleServices + ,ServiceMode (..) + ,ngxExportSimpleService + ,ngxExportSimpleServiceTyped + ,ngxExportSimpleServiceTypedAsJSON + -- * Re-exported functions needed for building simple services + ,unsafePerformIO + ) where + +import NgxExport + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Foreign.Ptr +import Foreign.Storable +import Foreign.C.Types +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as L +import Data.IORef +import Data.Maybe +import Data.Aeson +import Control.Monad +import Control.Concurrent +import GHC.Generics +import System.IO.Unsafe (unsafePerformIO) +import Safe + +foreign import ccall "exit" exit :: CInt -> IO () + +-- | Terminates current Nginx worker process. +-- +-- Nginx master process shall spawn a new worker process thereafter. +exitWorkerProcess :: IO () +exitWorkerProcess = exit 1 + +-- | Terminates current Nginx worker process. +-- +-- Nginx master process shall /not/ spawn a new worker process thereafter. +terminateWorkerProcess :: IO () +terminateWorkerProcess = exit 2 + +-- | Returns current time as the number of seconds elapsed since 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 = 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 + | Sec Int -- ^ Seconds + | HrMin Int Int -- ^ Hours and minutes + | MinSec Int Int -- ^ Minutes and seconds + deriving (Generic, Lift, Read) +instance FromJSON TimeInterval + +-- | Converts a time interval into seconds. +toSec :: TimeInterval -> Int +toSec (Hr h) = 3600 * h +toSec (Min m) = 60 * m +toSec (Sec s) = s +toSec (HrMin h m) = 3600 * h + 60 * m +toSec (MinSec m s) = 60 * m + s + +-- $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 \#\-} +-- +-- 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 +-- +-- test :: ByteString -> Bool -> IO L.ByteString +-- __/test/__ = const . return . L.fromStrict +-- 'ngxExportSimpleService' \'test $ +-- 'PersistentService' $ Just $ 'Sec' 10 +-- +-- newtype ConfRead = ConfRead Int deriving (Read, Show) +-- +-- testRead :: ConfRead -> Bool -> IO L.ByteString +-- __/testRead/__ c = const $ return $ C8L.pack $ show c +-- 'ngxExportSimpleServiceTyped' \'testRead \'\'ConfRead $ +-- 'PersistentService' $ Just $ 'Sec' 10 +-- +-- data ConfReadJSON = ConfReadJSONCon1 Int +-- | ConfReadJSONCon2 deriving (Generic, Show) +-- instance FromJSON ConfReadJSON +-- +-- testReadJSON :: ConfReadJSON -> Bool -> IO L.ByteString +-- __/testReadJSON/__ c = const $ return $ C8L.pack $ show c +-- 'ngxExportSimpleServiceTypedAsJSON' \'testReadJSON \'\'ConfReadJSON +-- '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: +-- +-- * 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. Under the hood, the +-- single-shot strategy is implemented as periodical sleeps (with period of +-- @'Hr' 1@), except it runs the handler only on the first iteration, while +-- 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. +-- +-- 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_testRead/__ $hs_testRead +-- \'ConfRead 20\'; +-- +-- haskell_run_service __/simpleService_testReadJSON/__ $hs_testReadJSON +-- \'{\"tag\":\"ConfReadJSONCon1\", \"contents\":56}\'; +-- +-- haskell_service_var_ignore_empty $hs_testReadJSON; +-- +-- server { +-- listen 8010; +-- server_name main; +-- error_log \/tmp\/nginx-test-haskell-error.log; +-- 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\"; +-- } +-- } +-- } +-- @ +-- +-- Notice that Haskel handlers defined in /test_tools.hs/ are referred from +-- the Nginx configuration file with prefix __/simpleService_/__. +-- +-- Let's run a simple test. +-- +-- > $ 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 + +-- | Defines a sleeping strategy. +-- +-- Single-shot services should be accompanied by Nginx directive +-- __/haskell_service_var_ignore_empty/__. +data ServiceMode + -- | Persistent service (with or without periodical sleeps) + = PersistentService (Maybe TimeInterval) + -- | Single-shot service + | SingleShotService + +simpleServiceWrap :: + (a -> Bool -> IO L.ByteString) -> a -> Bool -> IO L.ByteString +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) + |] + ) + [] + ] + ] + ,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. +-- +-- The service expects a plain 'ByteString' as its first argument. +ngxExportSimpleService :: Name -- ^ Name of the service + -> ServiceMode -- ^ Service mode + -> Q [Dec] +ngxExportSimpleService f = + ngxExportSimpleService' f Nothing + +-- | Exports a simple service with specified name and service mode. +-- +-- The service expects a custom type deriving 'Read' as its first argument. +-- For the sake of efficiency, the object of this custom type gets deserialized +-- into a global 'IORef' data storage on the first service run to be further +-- accessed directly from the storage. +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 with specified name and service mode. +-- +-- The service expects a custom type deriving 'FromJSON' as its first argument. +-- For the sake of efficiency, the object of this custom type gets deserialized +-- into a global 'IORef' data storage on the first service run to be further +-- accessed directly from the storage. +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) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/ngx-export-tools.cabal b/ngx-export-tools.cabal new file mode 100644 --- /dev/null +++ b/ngx-export-tools.cabal @@ -0,0 +1,29 @@ +name: ngx-export-tools +version: 0.1.0.0 +synopsis: Extra tools for Nginx haskell module +description: Extra tools for + +homepage: http://github.com/lyokha/nginx-haskell-module +license: BSD3 +license-file: LICENSE +extra-source-files: Changelog.md +author: Alexey Radkov +maintainer: Alexey Radkov +stability: experimental +copyright: 2018 Alexey Radkov +category: Network +build-type: Simple +cabal-version: >= 1.8 + +library + build-depends: base >= 4.8 && < 5 + , template-haskell >= 2.11.0.0 + , ngx-export >= 1.4.1 + , bytestring >= 0.10.0.0 + , aeson >= 1.0 + , safe + + exposed-modules: NgxExport.Tools + + ghc-options: -Wall -Wno-unused-top-binds -Wno-unused-matches +