{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface, TypeFamilies #-}
{-# LANGUAGE EmptyDataDecls, 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
-- <http://github.com/lyokha/nginx-haskell-module nginx-haskell-module>.
--
-----------------------------------------------------------------------------
module NgxExport.Tools (
-- * Various useful functions and data
exitWorkerProcess
,terminateWorkerProcess
,ngxRequestPtr
,ngxNow
-- *** Time intervals
,TimeInterval (..)
,toSec
,threadDelaySec
-- *** Reading custom types from /ByteStrings/
,readFromByteString
,readFromByteStringAsJSON
-- * Exporters of simple services
-- $simpleServices
,ServiceMode (..)
,ngxExportSimpleService
,ngxExportSimpleServiceTyped
,ngxExportSimpleServiceTypedAsJSON
-- * 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 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 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
-- | Unmarshals 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. 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 = wordPtrToPtr . fromIntegral . runGet getWordhost . L.fromStrict
-- | 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
-- | 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
-- | 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/
-- 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.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
--
-- testRead :: (Read a, Show a) => a -> Bool -> IO L.ByteString
-- testRead = const . return . C8L.pack . show
--
-- testReadInt :: Int -> Bool -> IO L.ByteString
-- __/testReadInt/__ = testRead
-- 'ngxExportSimpleServiceTyped' \'testReadInt \'\'Int $
-- 'PersistentService' $ Just $ 'Sec' 10
--
-- newtype Conf = Conf Int deriving (Read, Show)
--
-- 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 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'@)
--
-- 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 the services in the example ignore their second parameter (of type
-- 'Prelude.Bool') which denotes 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_testReadInt/__
-- $hs_testReadInt
-- 5000000;
--
-- haskell_run_service __/simpleService_testReadConf/__
-- $hs_testReadConf
-- \'Conf 20\';
--
-- haskell_run_service __/simpleService_testReadConfJSON/__
-- $hs_testReadConfJSON
-- \'{\"tag\":\"ConfJSONCon1\", \"contents\":56}\';
--
-- haskell_service_var_ignore_empty $hs_testReadConfJSON;
--
-- 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_testReadInt: $hs_testReadInt";
-- echo \" hs_testReadConf: $hs_testReadConf";
-- echo \" hs_testReadConfJSON: $hs_testReadConfJSON";
-- }
-- }
-- }
-- @
--
-- 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_testReadInt: 5000000
-- > hs_testReadConf: Conf 20
-- > hs_testReadConfJSON: ConfJSONCon1 56
-- | 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 = 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
]
-- | Exports a simple service with specified name and service mode.
--
-- The service expects a plain 'ByteString' object 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 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. 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
-> Q [Dec]
ngxExportSimpleServiceTyped f c =
ngxExportSimpleService' f $ Just (c, False)
-- | Exports a simple service with specified name and service mode.
--
-- 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. 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
-> Q [Dec]
ngxExportSimpleServiceTypedAsJSON f c =
ngxExportSimpleService' f $ Just (c, True)