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 <- ((/= 0) -> 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 -> IO CInt|]
ngxExportSSS =
ngxExport 'SSS 'sSS
[t|CString -> CInt -> CString -> CInt -> Ptr CString -> IO CInt|]
ngxExportSLS =
ngxExport 'SLS 'sLS
[t|Ptr NgxStrType -> CInt -> Ptr CString -> IO CInt|]
ngxExportBS =
ngxExport 'BS 'bS
[t|CString -> CInt -> IO CUInt|]
ngxExportBSS =
ngxExport 'BSS 'bSS
[t|CString -> CInt -> CString -> CInt -> IO CUInt|]
ngxExportBLS =
ngxExport 'BLS 'bLS
[t|Ptr NgxStrType -> CInt -> IO CUInt|]
ngxExportYY =
ngxExport 'YY 'yY
[t|CString -> CInt -> Ptr CString -> IO CInt|]
ngxExportBY =
ngxExport 'BY 'bY
[t|CString -> CInt -> IO CUInt|]
ngxExportIOYY =
ngxExportC 'IOYY 'ioyY
[t|CString -> CInt -> Ptr CString -> IO CInt|]
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 -> IO CInt|]
ngxExportDefHandler =
ngxExport 'YY 'defHandler
[t|CString -> CInt -> Ptr (Ptr NgxStrType) -> IO CInt|]
ngxExportUnsafeHandler =
ngxExport 'UnsafeHandler 'unsafeHandler
[t|CString -> CInt ->
Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize -> IO CInt|]
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
catchAlloc :: IO (Ptr a) -> IO (Ptr a)
catchAlloc = (`catchIOError` const (return nullPtr))
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 :: CString -> CSize -> Ptr CString -> Ptr CSize -> 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 <- catchAlloc $ mallocBytes 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 <- catchAlloc $ mallocBytes $
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 <- catchAlloc $ mallocBytes 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 -> IO CInt
sS (SS f) x (I n) p = do
PtrLen s l <- f <$> peekCStringLen (x, n)
>>= newCStringLen
poke p s
return l
sSS :: NgxExport -> CString -> CInt -> CString -> CInt -> Ptr CString -> IO CInt
sSS (SSS f) x (I n) y (I m) p = do
PtrLen s l <- f <$> peekCStringLen (x, n)
<*> peekCStringLen (y, m)
>>= newCStringLen
poke p s
return l
sLS :: NgxExport -> Ptr NgxStrType -> CInt -> Ptr CString -> IO CInt
sLS (SLS f) x (I n) p = do
PtrLen s l <- f <$> peekNgxStringArrayLen x n
>>= newCStringLen
poke p s
return l
yY :: NgxExport -> CString -> CInt -> Ptr CString -> IO CInt
yY (YY f) x (I n) p = do
s <- f <$> B.unsafePackCStringLen (x, n)
pokeLazyByteString s p
ioyY :: NgxExport -> CString -> CInt -> Ptr CString -> IO CInt
ioyY (IOYY f) x (I n) p = do
s <- (B.unsafePackCStringLen (x, n) >>= flip f False)
`catch` \e -> return $ C8L.pack $ show (e :: SomeException)
pokeLazyByteString s p
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 $
((Right <$> a)
`catch` (\e -> return $ Left $ show (e :: SomeException)) >>=
either
(\s -> do
PtrLen x l <- newCStringLen s
pokeCStringLen x l p pl
poke r 1
)
(\s -> do
PtrLenFromMaybe t l <- toSingleBuffer s
pokeCStringLen t l p pl
poke r 0
)
)
`finally`
(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
in 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 -> IO CUInt
bS (BS f) x (I n) =
fromBool . f <$> peekCStringLen (x, n)
bSS :: NgxExport -> CString -> CInt -> CString -> CInt -> IO CUInt
bSS (BSS f) x (I n) y (I m) =
(fromBool .) . f <$> peekCStringLen (x, n)
<*> peekCStringLen (y, m)
bLS :: NgxExport -> Ptr NgxStrType -> CInt -> IO CUInt
bLS (BLS f) x (I n) =
fromBool . f <$> peekNgxStringArrayLen x n
bY :: NgxExport -> CString -> CInt -> IO CUInt
bY (BY f) x (I n) =
fromBool . f <$> B.unsafePackCStringLen (x, n)
handler :: NgxExport -> CString -> CInt ->
Ptr (Ptr NgxStrType) -> Ptr CInt -> Ptr CString -> Ptr CSize -> IO CInt
handler (Handler f) x (I n) ps pls pt plt = do
(s, mt, I st) <- f <$> B.unsafePackCStringLen (x, n)
PtrLenFromMaybe t l <- toBuffers s
poke ps t
poke pls l
PtrLen smt lmt <- newCStringLen mt
pokeCStringLen smt lmt pt plt
return st
defHandler :: NgxExport -> CString -> CInt -> Ptr (Ptr NgxStrType) -> IO CInt
defHandler (YY f) x (I n) ps = do
s <- f <$> B.unsafePackCStringLen (x, n)
PtrLenFromMaybe t l <- toBuffers s
poke ps t
return l
unsafeHandler :: NgxExport -> CString -> CInt ->
Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize -> IO CInt
unsafeHandler (UnsafeHandler f) x (I n) ps pls pt plt = do
(s, mt, I st) <- f <$> B.unsafePackCStringLen (x, n)
PtrLen t lt <- B.unsafeUseAsCStringLen s return
pokeCStringLen t lt ps pls
PtrLen smt lmt <- B.unsafeUseAsCStringLen mt return
pokeCStringLen smt lmt pt plt
return st
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)