module NgxExport (
ngxExportSS
,ngxExportSSS
,ngxExportSLS
,ngxExportBS
,ngxExportBSS
,ngxExportBLS
,ngxExportYY
,ngxExportBY
,ngxExportIOYY
,ngxExportAsyncIOYY
,ngxExportAsyncOnReqBody
,ngxExportServiceIOYY
,ngxExportHandler
,ngxExportDefHandler
,ngxExportUnsafeHandler
,Foreign.C.CInt (..)
,Foreign.C.CUInt (..)) where
import Language.Haskell.TH
import Foreign.C
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import System.IO.Error
import System.Posix.IO
import Control.Monad
import Control.Exception hiding (Handler)
import GHC.IO.Exception (ioe_errno)
import Control.Concurrent.Async
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as C8L
import Data.Binary.Put
import Paths_ngx_export (version)
import Data.Version
pattern I i <- (fromIntegral -> i)
pattern PtrLen s l <- (s, I l)
pattern PtrLenFromMaybe s l <- (fromMaybe (nullPtr, 1) -> PtrLen s l)
pattern ToBool i <- (toBool -> i)
pattern EmptyLBS <- (L.null -> True)
data NgxExport = SS (String -> String)
| SSS (String -> String -> String)
| SLS ([String] -> String)
| BS (String -> Bool)
| BSS (String -> String -> Bool)
| BLS ([String] -> Bool)
| YY (B.ByteString -> L.ByteString)
| BY (B.ByteString -> Bool)
| IOYY (B.ByteString -> Bool -> IO L.ByteString)
| IOYYY (L.ByteString -> B.ByteString -> IO L.ByteString)
| Handler (B.ByteString -> (L.ByteString, String, Int))
| UnsafeHandler (B.ByteString ->
(B.ByteString, B.ByteString, Int))
let name = mkName "exportType" in do
TyConI (DataD _ _ _ _ cs _) <- reify ''NgxExport
let cons = map (\(NormalC con _) -> con) cs
sequence
[sigD name [t|NgxExport -> IO CInt|],
funD name $
map (\(c, i) -> clause [conP c [wildP]] (normalB [|return i|]) [])
(zip cons [1 ..] :: [(Name, Int)])
]
ngxExport' :: (Name -> Q Exp) -> Name -> Name -> Q Type -> Name -> Q [Dec]
ngxExport' m e h t f = sequence
[sigD nameFt typeFt,
funD nameFt $ body [|exportType $efVar|],
ForeignD . ExportF CCall ftName nameFt <$> typeFt,
sigD nameF t,
funD nameF $ body [|$hVar $efVar|],
ForeignD . ExportF CCall fName nameF <$> t
]
where hVar = varE h
efVar = conE e `appE` m f
fName = "ngx_hs_" ++ nameBase f
nameF = mkName fName
ftName = "type_" ++ fName
nameFt = mkName ftName
typeFt = [t|IO CInt|]
body b = [clause [] (normalB b) []]
ngxExport :: Name -> Name -> Q Type -> Name -> Q [Dec]
ngxExport = ngxExport' varE
ngxExportC :: Name -> Name -> Q Type -> Name -> Q [Dec]
ngxExportC = ngxExport' $ infixE (Just $ varE 'const) (varE '(.)) . Just . varE
ngxExportSS =
ngxExport 'SS 'sS
[t|CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt|]
ngxExportSSS =
ngxExport 'SSS 'sSS
[t|CString -> CInt -> CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt|]
ngxExportSLS =
ngxExport 'SLS 'sLS
[t|Ptr NgxStrType -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt|]
ngxExportBS =
ngxExport 'BS 'bS
[t|CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt|]
ngxExportBSS =
ngxExport 'BSS 'bSS
[t|CString -> CInt -> CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt|]
ngxExportBLS =
ngxExport 'BLS 'bLS
[t|Ptr NgxStrType -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt|]
ngxExportYY =
ngxExport 'YY 'yY
[t|CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt|]
ngxExportBY =
ngxExport 'BY 'bY
[t|CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt|]
ngxExportIOYY =
ngxExportC 'IOYY 'ioyY
[t|CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt|]
ngxExportAsyncIOYY =
ngxExportC 'IOYY 'asyncIOYY
[t|CString -> CInt -> CInt -> CUInt -> CUInt ->
Ptr CString -> Ptr CSize -> Ptr CUInt -> IO ()|]
ngxExportAsyncOnReqBody =
ngxExport 'IOYYY 'asyncIOYYY
[t|Ptr NgxStrType -> CInt -> CString -> CInt ->
CInt -> CUInt -> Ptr CString -> Ptr CSize -> Ptr CUInt -> IO ()|]
ngxExportServiceIOYY =
ngxExport 'IOYY 'asyncIOYY
[t|CString -> CInt -> CInt -> CUInt -> CUInt ->
Ptr CString -> Ptr CSize -> Ptr CUInt -> IO ()|]
ngxExportHandler =
ngxExport 'Handler 'handler
[t|CString -> CInt -> Ptr (Ptr NgxStrType) -> Ptr CInt ->
Ptr CString -> Ptr CSize -> Ptr CInt -> IO CUInt|]
ngxExportDefHandler =
ngxExport 'YY 'defHandler
[t|CString -> CInt ->
Ptr (Ptr NgxStrType) -> Ptr CInt -> Ptr CString -> IO CUInt|]
ngxExportUnsafeHandler =
ngxExport 'UnsafeHandler 'unsafeHandler
[t|CString -> CInt -> Ptr CString -> Ptr CSize ->
Ptr CString -> Ptr CSize -> Ptr CInt -> IO CUInt|]
data NgxStrType = NgxStrType CSize CString
instance Storable NgxStrType where
alignment _ = max (alignment (undefined :: CSize))
(alignment (undefined :: CString))
sizeOf = (2 *) . alignment
peek p = do
n <- peekByteOff p 0
s <- peekByteOff p $ alignment (undefined :: NgxStrType)
return $ NgxStrType n s
poke p x@(NgxStrType n s) = do
poke (castPtr p) n
poke (plusPtr p $ alignment x) s
safeMallocBytes :: Int -> IO (Ptr a)
safeMallocBytes =
flip catchIOError (const $ return nullPtr) . mallocBytes
safeNewCStringLen :: String -> IO CStringLen
safeNewCStringLen =
flip catchIOError (const $ return (nullPtr, 1)) . newCStringLen
safeHandler :: Ptr CString -> Ptr CInt -> IO CUInt -> IO CUInt
safeHandler p pl = handle $ \e -> do
PtrLen x l <- safeNewCStringLen $ show (e :: SomeException)
pokeCStringLen x l p pl
return 1
peekNgxStringArrayLen :: Ptr NgxStrType -> Int -> IO [String]
peekNgxStringArrayLen x n = sequence $
foldr (\k ->
((peekElemOff x k >>=
(\(NgxStrType (I m) y) ->
peekCStringLen (y, m))) :)) [] [0 .. n 1]
peekNgxStringArrayLenY :: Ptr NgxStrType -> Int -> IO L.ByteString
peekNgxStringArrayLenY x n = L.fromChunks <$> sequence
(foldr (\k ->
((peekElemOff x k >>=
(\(NgxStrType (I m) y) ->
B.unsafePackCStringLen (y, m))) :)) [] [0 .. n 1])
pokeCStringLen :: (Storable a, Num a) =>
CString -> a -> Ptr CString -> Ptr a -> IO ()
pokeCStringLen x n p s = poke p x >> poke s n
pokeLazyByteString :: L.ByteString -> Ptr CString -> IO CInt
pokeLazyByteString s p = do
PtrLenFromMaybe t l <- toSingleBuffer s
poke p t
return l
toSingleBuffer :: L.ByteString -> IO (Maybe CStringLen)
toSingleBuffer EmptyLBS =
return $ Just (nullPtr, 0)
toSingleBuffer s = do
let I l = L.length s
t <- safeMallocBytes l
if t /= nullPtr
then do
void $ L.foldlChunks
(\a s -> do
off <- a
let l = B.length s
B.unsafeUseAsCString s $ flip (copyBytes $ plusPtr t off) l
return $ off + l
) (return 0) s
return $ Just (t, l)
else return Nothing
toBuffers :: L.ByteString -> IO (Maybe (Ptr NgxStrType, Int))
toBuffers EmptyLBS =
return $ Just (nullPtr, 0)
toBuffers s = do
t <- safeMallocBytes $
L.foldlChunks (const . succ) 0 s * sizeOf (undefined :: NgxStrType)
l <- L.foldlChunks
(\a s -> do
off <- a
maybe (return Nothing)
(\off -> do
let l = B.length s
dst <- safeMallocBytes l
if dst /= nullPtr
then do
B.unsafeUseAsCString s $ flip (copyBytes dst) l
pokeElemOff t off $ NgxStrType (fromIntegral l) dst
return $ Just $ off + 1
else do
mapM_
(peekElemOff t >=> \(NgxStrType _ x) -> free x)
[0 .. off 1]
free t
return Nothing
) off
) (return $ if t /= nullPtr then Just 0 else Nothing) s
return $ l >>= Just . (,) t
sS :: NgxExport -> CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt
sS (SS f) x (I n) p pl =
safeHandler p pl $ do
PtrLen s l <- f <$> peekCStringLen (x, n)
>>= newCStringLen
pokeCStringLen s l p pl
return 0
sSS :: NgxExport -> CString -> CInt -> CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt
sSS (SSS f) x (I n) y (I m) p pl =
safeHandler p pl $ do
PtrLen s l <- f <$> peekCStringLen (x, n)
<*> peekCStringLen (y, m)
>>= newCStringLen
pokeCStringLen s l p pl
return 0
sLS :: NgxExport -> Ptr NgxStrType -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt
sLS (SLS f) x (I n) p pl =
safeHandler p pl $ do
PtrLen s l <- f <$> peekNgxStringArrayLen x n
>>= newCStringLen
pokeCStringLen s l p pl
return 0
yY :: NgxExport -> CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt
yY (YY f) x (I n) p pl =
safeHandler p pl $ do
s <- f <$> B.unsafePackCStringLen (x, n)
pokeLazyByteString s p >>= poke pl
return 0
ioyY :: NgxExport -> CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt
ioyY (IOYY f) x (I n) p pl = do
(s, r) <- (do
s <- B.unsafePackCStringLen (x, n) >>= flip f False
fmap (flip (,) 0) $ return $! s
) `catch` \e -> return (C8L.pack $ show (e :: SomeException), 1)
pokeLazyByteString s p >>= poke pl
return r
asyncIOFlag1b :: B.ByteString
asyncIOFlag1b = L.toStrict $ runPut $ putInt8 1
asyncIOFlag8b :: B.ByteString
asyncIOFlag8b = L.toStrict $ runPut $ putInt64host 1
asyncIOCommon :: IO C8L.ByteString ->
CInt -> Bool -> Ptr CString -> Ptr CSize -> Ptr CUInt -> IO ()
asyncIOCommon a (I fd) efd p pl r = void . async $ do
(do {s <- a; fmap Right $ return $! s})
`catch` (\e -> return $ Left $ show (e :: SomeException)) >>=
either
(\s -> do
PtrLen x l <- safeNewCStringLen s
pokeCStringLen x l p pl
poke r 1
)
(\s -> do
PtrLenFromMaybe t l <- toSingleBuffer s
pokeCStringLen t l p pl
poke r 0
)
let writeBufN n s w
| w < n = (w +) <$>
fdWriteBuf fd (plusPtr s $ fromIntegral w) (n w)
`catchIOError`
(\e -> return $
if ioe_errno e == Just ((\(Errno e) -> e) eINTR)
then 0
else n
) >>= writeBufN n s
| otherwise = return w
writeFlag1b = void $
B.unsafeUseAsCString asyncIOFlag1b $ flip (writeBufN 1) 0
writeFlag8b = void $
B.unsafeUseAsCString asyncIOFlag8b $ flip (writeBufN 8) 0
if efd
then writeFlag8b
else writeFlag1b >> closeFd fd `catchIOError` const (return ())
asyncIOYY :: NgxExport -> CString -> CInt ->
CInt -> CUInt -> CUInt -> Ptr CString -> Ptr CSize -> Ptr CUInt -> IO ()
asyncIOYY (IOYY f) x (I n) fd (ToBool efd) (ToBool fstRun) =
asyncIOCommon (B.unsafePackCStringLen (x, n) >>= flip f fstRun) fd efd
asyncIOYYY :: NgxExport -> Ptr NgxStrType -> CInt -> CString -> CInt ->
CInt -> CUInt -> Ptr CString -> Ptr CSize -> Ptr CUInt -> IO ()
asyncIOYYY (IOYYY f) b (I m) x (I n) fd (ToBool efd) =
asyncIOCommon
(do
b' <- peekNgxStringArrayLenY b m
x' <- B.unsafePackCStringLen (x, n)
f b' x'
) fd efd
bS :: NgxExport -> CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt
bS (BS f) x (I n) p pl =
safeHandler p pl $ do
r <- fromBool . f <$> peekCStringLen (x, n)
pokeCStringLen nullPtr 0 p pl
return r
bSS :: NgxExport -> CString -> CInt -> CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt
bSS (BSS f) x (I n) y (I m) p pl =
safeHandler p pl $ do
r <- (fromBool .) . f <$> peekCStringLen (x, n)
<*> peekCStringLen (y, m)
pokeCStringLen nullPtr 0 p pl
return r
bLS :: NgxExport -> Ptr NgxStrType -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt
bLS (BLS f) x (I n) p pl =
safeHandler p pl $ do
r <- fromBool . f <$> peekNgxStringArrayLen x n
pokeCStringLen nullPtr 0 p pl
return r
bY :: NgxExport -> CString -> CInt ->
Ptr CString -> Ptr CInt -> IO CUInt
bY (BY f) x (I n) p pl =
safeHandler p pl $ do
r <- fromBool . f <$> B.unsafePackCStringLen (x, n)
pokeCStringLen nullPtr 0 p pl
return r
handler :: NgxExport -> CString -> CInt -> Ptr (Ptr NgxStrType) -> Ptr CInt ->
Ptr CString -> Ptr CSize -> Ptr CInt -> IO CUInt
handler (Handler f) x (I n) p pl pct plct pst =
safeHandler pct pst $ do
(s, ct, I st) <- f <$> B.unsafePackCStringLen (x, n)
PtrLenFromMaybe t l <- toBuffers s
poke p t >> poke pl l
PtrLen sct lct <- newCStringLen ct
pokeCStringLen sct lct pct plct >> poke pst st
return 0
defHandler :: NgxExport -> CString -> CInt ->
Ptr (Ptr NgxStrType) -> Ptr CInt -> Ptr CString -> IO CUInt
defHandler (YY f) x (I n) p pl pe =
safeHandler pe pl $ do
s <- f <$> B.unsafePackCStringLen (x, n)
PtrLenFromMaybe t l <- toBuffers s
poke p t >> poke pl l
return 0
unsafeHandler :: NgxExport -> CString -> CInt -> Ptr CString -> Ptr CSize ->
Ptr CString -> Ptr CSize -> Ptr CInt -> IO CUInt
unsafeHandler (UnsafeHandler f) x (I n) p pl pct plct pst =
safeHandler pct pst $ do
(s, ct, I st) <- f <$> B.unsafePackCStringLen (x, n)
PtrLen t l <- B.unsafeUseAsCStringLen s return
pokeCStringLen t l p pl
PtrLen sct lct <- B.unsafeUseAsCStringLen ct return
pokeCStringLen sct lct pct plct >> poke pst st
return 0
foreign export ccall ngxExportVersion :: Ptr CInt -> CInt -> IO CInt
ngxExportVersion :: Ptr CInt -> CInt -> IO CInt
ngxExportVersion x (I n) = fromIntegral <$>
foldM (\k (I v) -> pokeElemOff x k v >> return (k + 1)) 0
(take n $ versionBranch version)