{-# 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' :: Name -> Maybe (Name, Bool) -> ServiceMode -> Q [Dec]
ngxExportSimpleService' Name
f Maybe (Name, Bool)
c ServiceMode
m = do
    Name
confBs <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"confBs_"
    Name
fstRun <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"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
$ String
"simpleService_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameF
        hasConf :: Bool
hasConf = Maybe (Name, Bool) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Name, Bool)
c
        (Name
sNameC, Q Type
typeC, Q Exp
readConf, String
unreadableConfMsg) =
            if Bool
hasConf
                then let ((Name
tName, String
tNameBase), Bool
isJSON) =
                             (Name -> (Name, String)) -> (Name, Bool) -> ((Name, String), Bool)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Name -> Name
forall a. a -> a
id (Name -> Name) -> (Name -> String) -> Name -> (Name, String)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Name -> String
nameBase) ((Name, Bool) -> ((Name, String), Bool))
-> (Name, Bool) -> ((Name, 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
$ String
"storage_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tNameBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: String
nameF
                        ,Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tName
                        ,if Bool
isJSON
                             then [|readFromByteStringAsJSON|]
                             else [|readFromByteString|]
                        ,String
"Configuration " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tNameBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not readable"
                        )
                else (Name, Q Type, Q Exp, String)
forall a. HasCallStack => a
undefined
        initConf :: Q Exp
initConf =
            let eConfBs :: Q Exp
eConfBs = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
confBs
            in if Bool
hasConf
                   then let storage :: Q Exp
storage = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
sNameC
                        in [|readIORef $(Q Exp
storage) >>=
                                 maybe
                                     (do
                                          let conf_data__ =
                                                  $(Q Exp
readConf) $(Q Exp
eConfBs)
                                          when (isNothing conf_data__) $
                                              terminateWorkerProcess
                                                  unreadableConfMsg
                                          writeIORef $(Q Exp
storage) conf_data__
                                          return conf_data__
                                     ) (return . Just)
                           |]
                   else [|return $ Just $(Q Exp
eConfBs)|]
        (Q Exp
waitTime, Q Exp
runService) =
            let eF :: Q Exp
eF = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f
                eFstRun :: Q Exp
eFstRun = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fstRun
                runPersistentService :: Q Exp
runPersistentService = [|flip $(Q Exp
eF) $(Q Exp
eFstRun)|]
            in case ServiceMode
m of
                   PersistentService (Just TimeInterval
t) ->
                       ([|const $ unless $(Q Exp
eFstRun) $ threadDelaySec $ toSec t|]
                       ,Q Exp
runPersistentService
                       )
                   PersistentService Maybe TimeInterval
Nothing ->
                       ([|const $ return ()|]
                       ,Q Exp
runPersistentService
                       )
                   ServiceMode
SingleShotService ->
                       ([|\conf_data__ -> unless $(Q Exp
eFstRun) $
                              handle
                                  (const $ void $ $(Q Exp
eF) conf_data__ False ::
                                      WorkerProcessIsExiting -> IO ()
                                  ) $ forever $ threadDelaySec $ toSec $ Hr 24
                        |]
                       ,[|\conf_data__ ->
                              if $(Q Exp
eFstRun)
                                  then $(Q Exp
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)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
        [[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
            (if Bool
hasConf
                 then [Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
sNameC [t|IORef (Maybe $(Q Type
typeC))|]
                      ,Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
sNameC
                          [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                              (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|unsafePerformIO $ newIORef Nothing|])
                              []
                          ]
                      ,Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
sNameC Inline
NoInline RuleMatch
FunLike Phases
AllPhases
                      ]
                 else []
            )
            [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++
            [Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
nameSsf [t|ByteString -> Bool -> IO L.ByteString|]
            ,Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
nameSsf
                [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
confBs, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fstRun]
                    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|do
                                   conf_data_ <- fromJust <$> $(Q Exp
initConf)
                                   $(Q Exp
waitTime) conf_data_
                                   $(Q Exp
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 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 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 :: Name -> Name -> ServiceMode -> Q [Dec]
ngxExportSimpleServiceTyped Name
f 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
--
-- @
-- 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 :: Name -> Name -> ServiceMode -> Q [Dec]
ngxExportSimpleServiceTypedAsJSON Name
f 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)