diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# Revision history for fb-util + +## 0.1.0.1 -- YYYY-mm-dd + +* Builds with GHC 9.8.x + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/Compat/Prettyprinter.hs b/Compat/Prettyprinter.hs new file mode 100644 --- /dev/null +++ b/Compat/Prettyprinter.hs @@ -0,0 +1,16 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} +-- | Just a compat layer to avoid CPP when using prettyprinter +{-# LANGUAGE CPP #-} +module Compat.Prettyprinter (module P) where + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter as P +#else +import Data.Text.Prettyprint.Doc as P +#endif diff --git a/Compat/Prettyprinter/Render/Text.hs b/Compat/Prettyprinter/Render/Text.hs new file mode 100644 --- /dev/null +++ b/Compat/Prettyprinter/Render/Text.hs @@ -0,0 +1,16 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} +-- | Just a compat layer to avoid CPP when using prettyprinter +{-# LANGUAGE CPP #-} +module Compat.Prettyprinter.Render.Text (module P) where + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter.Render.Text as P +#else +import Data.Text.Prettyprint.Doc.Render.Text as P +#endif diff --git a/Compat/Prettyprinter/Util.hs b/Compat/Prettyprinter/Util.hs new file mode 100644 --- /dev/null +++ b/Compat/Prettyprinter/Util.hs @@ -0,0 +1,16 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} +-- | Just a compat layer to avoid CPP when using prettyprinter +{-# LANGUAGE CPP #-} +module Compat.Prettyprinter.Util (module P) where + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter.Util as P +#else +import Data.Text.Prettyprint.Doc.Util as P +#endif diff --git a/Control/Concurrent/Stream.hs b/Control/Concurrent/Stream.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Stream.hs @@ -0,0 +1,162 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- | Higher level concurrency facilities for multiple workers concurrently +-- over a streaming source of input + +module Control.Concurrent.Stream + ( stream + , streamBound + , streamWithState + , streamWithResourceBound + , mapConcurrently_unordered + , forConcurrently_unordered + ) where + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Exception +import Control.Monad + +import Util.Control.Exception +import Util.Log +import Data.IORef +import Data.IORef.Extra + +data ShouldBindThreads = BoundThreads | UnboundThreads + +data ShouldThrow = ThrowExceptions | SwallowExceptions + +-- | Maps workers concurrently over a stream of values with a bounded size +-- +-- Runs the producer until it terminates, passing in a function to add things +-- into the stream. Runs at most `maxConcurrency` threads simultaneously to +-- process things put into the stream. +-- There's no end aggregation for the output from each worker, which doesn't +-- make this composable. We can add that in the future when needed. +-- +-- If a worker throws a synchronous exception, it will be +-- propagated to the caller. +-- +-- `conduit` and `pipes` provide functionality for running consecutive stages +-- in parallel, but nothing for running a single stage concurrently. +stream + :: Int -- ^ Maximum Concurrency + -> ((a -> IO ()) -> IO ()) -- ^ Producer + -> (a -> IO ()) -- ^ Worker + -> IO () +stream maxConcurrency producer worker = + streamWithState producer (replicate maxConcurrency ()) $ const worker + +-- | Like stream, but uses bound threads for the workers. See +-- 'Control.Concurrent.forkOS' for details on bound threads. +streamBound + :: Int -- ^ Maximum Concurrency + -> ((a -> IO ()) -> IO ()) -- ^ Producer + -> (a -> IO ()) -- ^ Worker + -> IO () +streamBound maxConcurrency producer worker = + streamWithResourceBound maxConcurrency ($ ()) producer $ const worker + +-- | Like stream, but each worker keeps a state: the state can be a parameter +-- to the worker function, or a state that you can build upon (for example the +-- state can be an IORef of some sort) +-- There will be a thread per worker state +streamWithState + :: ((a -> IO ()) -> IO ()) -- ^ Producer + -> [b] -- ^ Worker state + -> (b -> a -> IO ()) -- ^ Worker + -> IO () +streamWithState producer states worker = stream_ UnboundThreads ThrowExceptions + ($ ()) producer states (const worker) + +-- | Like streamWithState but uses bound threads for the workers. +streamWithResourceBound + :: Int -- ^ Maximum concurrency + -> ((resource -> IO ()) -> IO ()) -- ^ Worker resource acquisition, per thread + -> ((a -> IO ()) -> IO ()) -- ^ Producer + -> (resource -> a -> IO ()) -- ^ Worker + -> IO () +streamWithResourceBound maxConcurrency withResource producer worker = + stream_ BoundThreads ThrowExceptions + withResource producer (replicate maxConcurrency ()) (\r _ -> worker r) + +stream_ + :: ShouldBindThreads -- use bound threads? + -> ShouldThrow -- propagate worker exceptions? + -> ((resource -> IO ()) -> IO ()) -- ^ resource acquisition + -> ((a -> IO ()) -> IO ()) -- ^ Producer + -> [b] -- Worker state + -> (resource -> b -> a -> IO ()) -- ^ Worker + -> IO () +stream_ useBoundThreads shouldThrow withResource producer workerStates worker + = do + let maxConcurrency = length workerStates + q <- atomically $ newTBQueue (fromIntegral maxConcurrency) + let write x = atomically $ writeTBQueue q (Just x) + mask $ \unmask -> + concurrently_ (runWorkers unmask q) $ unmask $ do + -- run the producer + producer write + -- write end-markers for all workers + replicateM_ maxConcurrency $ + atomically $ writeTBQueue q Nothing + where + runWorkers unmask q = case useBoundThreads of + BoundThreads -> + foldr1 concurrentlyBound $ + map (withResource . runWorker unmask q) workerStates + UnboundThreads -> + mapConcurrently_ (withResource . runWorker unmask q) workerStates + + concurrentlyBound l r = + withAsyncBound l $ \a -> + withAsyncBound r $ \b -> + void $ waitBoth a b + + runWorker unmask q s resource = do + v <- atomically $ readTBQueue q + case v of + Nothing -> return () + Just t -> do + e <- tryAll $ unmask $ worker resource s t + case e of + Left ex -> case shouldThrow of + ThrowExceptions -> throw ex + SwallowExceptions -> logError $ show ex + Right _ -> return () + runWorker unmask q s resource + +-- | Concurrent map over a stream of values. Results are unordered. +-- +-- Convenience interface over Control.Concurrent.Stream (stream), +-- for processing values in lists in the same manner as mapConcurrently. +-- The list of output values may not be in the same order as the list +-- of input values. +mapConcurrently_unordered + :: Int -- ^ Maximum concurrency + -> (a -> IO b) -- ^ Function to map over the input values + -> [a] -- ^ List of input values + -> IO [b] -- ^ List of output values (unordered) +mapConcurrently_unordered maxConcurrency transformIO input = do + outputRef <- Data.IORef.newIORef [] + stream maxConcurrency (forM_ input) $ \inputElement -> do + transformedElement <- transformIO inputElement + Data.IORef.Extra.atomicModifyIORef_ outputRef (transformedElement:) + Data.IORef.readIORef outputRef + +-- | Control.Concurrent.Stream (mapConcurrently) but with its arguments reversed +-- +-- The list of output values may not be in the same order as the list +-- of input values. +forConcurrently_unordered + :: Int -- ^ Maximum concurrency + -> [a] -- ^ List of input values + -> (a -> IO b) -- ^ Function to map over the input values + -> IO [b] -- ^ List of output values (unordered) +forConcurrently_unordered = flip . mapConcurrently_unordered diff --git a/Control/Trace.hs b/Control/Trace.hs new file mode 100644 --- /dev/null +++ b/Control/Trace.hs @@ -0,0 +1,36 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- | A tracing library inspired by dcoutts Contravariant logging talk[1] +-- and the co-log package. +-- +-- [1] - https://www.youtube.com/watch?v=qzOQOmmkKEM +-- +-- Example of usage: +-- +-- > tracer :: Tracer Text +-- > tracer = vlogTextTracer 1 +-- > +-- > main = traceMsg tracer "main" $ do +-- > putStrLn "Hello world" +-- +module Control.Trace + ( Tracer + , logMsg + , traceMsg + , traceIf + , (>$<) + , vlogTracer + , vlogTracerWithPriority + , TraceWithPriority(..) + , vlogShowTracer + , vlogTextTracer + ) where + +import Control.Trace.Core +import Control.Trace.VLog diff --git a/Control/Trace/Core.hs b/Control/Trace/Core.hs new file mode 100644 --- /dev/null +++ b/Control/Trace/Core.hs @@ -0,0 +1,113 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS -Wno-orphans #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE InstanceSigs #-} +module Control.Trace.Core ( + Tracer (..), + MonadTrace (..), + MonadMaskInstance (..), + logMsg, + traceMsg, + traceIf, + Contravariant, + (>$<), +) where + +import Control.Monad (when) +import Control.Monad.Catch ( + ExitCase (..), + MonadCatch, + MonadMask (generalBracket), + MonadThrow, + ) +import Control.Monad.IO.Class ( + MonadIO (..), + ) +import Data.Coerce +import Data.Functor.Contravariant ( + Contravariant (contramap), + (>$<), + ) +import GHC.Stack ( + HasCallStack, + withFrozenCallStack, + ) + +-- | A contravariant tracing abstraction +data Tracer msg = Tracer + { -- | Log a message + logMsg_ :: msg -> IO () + , -- | Starts a trace and returns an action to end it + traceMsg_ + :: forall a. HasCallStack => msg -> IO (ExitCase a -> IO ()) + } + +logMsg :: (HasCallStack, MonadIO m) => Tracer msg -> msg -> m () +logMsg logger msg = withFrozenCallStack $ liftIO $ logMsg_ logger msg + +traceMsg :: + (HasCallStack, MonadTrace m) => Tracer msg -> msg -> m a -> m a +traceMsg logger msg act = withFrozenCallStack $ + bracketM (traceMsg_ logger msg) id (const act) + +instance Contravariant Tracer where + contramap f (Tracer logf traceF) = Tracer (logf . f) (traceF . f) + +instance Monoid (Tracer msg) where + mempty = Tracer (\_ -> pure ()) (const $ pure $ const $ pure ()) + +instance Semigroup (Tracer msg) where + l1 <> l2 = + Tracer + { logMsg_ = \m -> logMsg_ l1 m *> logMsg_ l2 m + , traceMsg_ = \msg -> do + end1 <- traceMsg_ l1 msg + end2 <- traceMsg_ l2 msg + return (\res -> end2 res >> end1 res) + } + +-------------------------------------------------------------------------------- +-- useful combinators + +-- | Gate every trace behind a condition +traceIf :: forall msg. IO Bool -> Tracer msg -> Tracer msg +traceIf cond tracer = + let + logMsg' msg = do + value <- cond + when value $ logMsg_ tracer msg + traceMsg' :: msg -> IO (ExitCase b -> IO ()) + traceMsg' msg = do + value <- cond + if value + then traceMsg_ tracer msg + else pure $ pure $ pure () + in Tracer logMsg' traceMsg' + +-------------------------------------------------------------------------------- +-- A Monad for 'bracket' + +class MonadIO m => MonadTrace m where + bracketM :: IO a -> (a -> ExitCase b -> IO ()) -> (a -> m b) -> m b + +-- deriving via (MonadMaskInstance IO) instance MonadTrace IO +instance MonadTrace IO where + bracketM + :: forall a b . IO a -> (a -> ExitCase b -> IO ()) -> (a -> IO b) -> IO b + bracketM = coerce (bracketM @(MonadMaskInstance IO) @a @b) + +-- | Deriving 'MonadTrace' via 'MonadMask' +newtype MonadMaskInstance m a = MonadMaskInstance (m a) + deriving + (Applicative, Functor, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow) + +instance (MonadIO m, MonadMask m) => MonadTrace (MonadMaskInstance m) where + bracketM acquire release = + fmap fst . generalBracket (liftIO acquire) ((liftIO .) . release) diff --git a/Control/Trace/VLog.hs b/Control/Trace/VLog.hs new file mode 100644 --- /dev/null +++ b/Control/Trace/VLog.hs @@ -0,0 +1,114 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE ViewPatterns, CPP #-} +module Control.Trace.VLog ( + vlogTracer, + TraceWithPriority (..), + vlogTracerWithPriority, + vlogShowTracer, + vlogTextTracer, +) where + +import Control.Monad (when) +import Control.Monad.Catch ( + ExitCase ( + ExitCaseAbort, + ExitCaseException, + ExitCaseSuccess + ), + ) +import Control.Monad.IO.Class +import Control.Trace.Core +import Data.Some +import Data.Text (Text) +import GHC.Stack +import TextShow ( + TextShow, + showt, + ) +import qualified Util.Log.String as String +import Util.Log.Text + +vlogShowTracer :: TextShow a => (a -> Int) -> Tracer a +vlogShowTracer = + vlogTracer + (\(showt -> x) -> ("BEGIN " <> x, \e -> "END" <> renderExitCase e <> x)) + showt + +renderExitCase :: Some ExitCase -> Text +renderExitCase (Some ExitCaseAbort {}) = "(aborted) " +renderExitCase (Some (ExitCaseException e)) = "(" <> showt e <> ") " +renderExitCase (Some ExitCaseSuccess {}) = " " + +vlogTextTracer :: Int -> Tracer Text +vlogTextTracer p = + vlogTracer + (\x -> ("BEGIN " <> x, \e -> "END" <> renderExitCase e <> x)) + id + (const p) + +data TraceWithPriority + = Skip + | T !Int !Text + | S !Int !String + +vlogTracerWithPriority :: Tracer TraceWithPriority +vlogTracerWithPriority = Tracer {..} + where + logMsg_ :: (HasCallStack, MonadIO m) => TraceWithPriority -> m () + logMsg_ Skip = pure () + logMsg_ x = withFrozenCallStack $ case x of + T p t -> vlog p t + S p s -> String.vlog p s +#if __GLASGOW_HASKELL__ < 902 + Skip -> error "unreachable" +#endif + + traceMsg_ msg = + case msg of + T p t -> do + vlog p ("BEGIN " <> t) + return ( \res -> case res of + ExitCaseSuccess {} -> vlog p ("END " <> t) + ExitCaseAbort {} -> vlog p ("ABORTED " <> t) + ExitCaseException e -> vlog p ("FAILED " <> t <> ": " <> showt e) + ) + S p t -> do + String.vlog p ("BEGIN " <> t) + return ( \res -> case res of + ExitCaseSuccess {} -> String.vlog p ("END " <> t) + ExitCaseAbort {} -> String.vlog p ("ABORTED " <> t) + ExitCaseException e -> + String.vlog p ("FAILED " <> t <> ": " <> show e) + ) + Skip -> return $ const $ return () + +vlogTracer :: + forall a. + -- | render BEGIN and END messages + (a -> (Text, Some ExitCase -> Text)) -> + -- | render LOG message + (a -> Text) -> + -- | Priority (use -1 to skip) + (a -> Int) -> + Tracer a +vlogTracer beginend log_ prio = Tracer {..} + where + logMsg_ :: a -> IO () + logMsg_ msg = + let p = prio msg + in when (p >= 0) $ vlog p $ log_ msg + + traceMsg_ :: a -> IO (ExitCase b -> IO ()) + traceMsg_ msg = do + let p = prio msg + (b, e) = beginend msg + if p >= 0 + then vlog p b >> return (\res -> vlog p (e $ mkSome res)) + else return $ const $ return () diff --git a/Data/MovingAverageRateLimiter.hs b/Data/MovingAverageRateLimiter.hs new file mode 100644 --- /dev/null +++ b/Data/MovingAverageRateLimiter.hs @@ -0,0 +1,105 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{- | +A standalone rate limiter that accepts some fluctuations in the traffic. + +QPS_new = QPS_old * exp(-alpha * t) + n * alpha +where alpha is the decay factor, t is the time elapsed and n is the number of +new requests (that are allowed). + +See also www/flib/social/ma_rate_limiter/MovingAverageRateLimiter.php +and fbcode/common/datastruct/MovingAverageRateLimiter.h +-} + +module Data.MovingAverageRateLimiter + ( RateLimiterConfig(qpsLimit, decayHalfLife) + , mkRateLimiterConfig + , RateLimiter(qps) + , mkRateLimiter + , updateConfig + , observedRate + , allow + ) where + +-- ---------------------------------------------------------------------------- + +data RateLimiterConfig = RateLimiterConfig + { qpsLimit :: {-# UNPACK #-} !Double -- ^ Query per second limit + , decayHalfLife :: {-# UNPACK #-} !Double + -- ^ Time in seconds for the weight of past query to decay to half + -- in moving average calculation + , alpha :: {-# UNPACK #-} !Double + } + +mkRateLimiterConfig + :: Double -- ^ query per second limit + -> Double -- ^ decay half life + -> RateLimiterConfig +mkRateLimiterConfig ql d = RateLimiterConfig + { qpsLimit = ql + , decayHalfLife = d + , alpha = log 2.0 / d + } + +updateConfig + :: Double -- ^ new query per second limit + -> Double -- ^ new decay half life + -> RateLimiterConfig -> RateLimiterConfig +updateConfig ql d r = r + { qpsLimit = ql + , decayHalfLife = d + , alpha = log 2.0 / d + } + +-- ---------------------------------------------------------------------------- + +data RateLimiter = RateLimiter + { qps :: {-# UNPACK #-} !Double + , lastTimestamp :: {-# UNPACK #-} !Double -- in sec + } + +mkRateLimiter :: RateLimiter +mkRateLimiter = RateLimiter + { qps = 0 + , lastTimestamp = 0 + } + +observedRate + :: RateLimiter + -> Double -- ^ queries per second + -> Double -- ^ timestamp of the last query + -> RateLimiter +observedRate r q t = r + { qps = q + , lastTimestamp = t + } + +allow + :: RateLimiterConfig + -> RateLimiter + -> Double -- ^ current timestamp + -> (Bool, RateLimiter) -- ^ should the query is allowed? and the new state +allow RateLimiterConfig{..} r@RateLimiter{..} t = (a, observedRate r q2 t) + where + timeDiff = t - lastTimestamp + q1 = if timeDiff > 0 then qps * exp (- alpha * timeDiff) else qps + (a, q2) | lastTimestamp == 0 = (True , qpsLimit * (1 - alpha) + alpha) + -- See Note [First Bump] + | q1 < qpsLimit = (True , q1 + alpha) + | otherwise = (False, q1) + +-- Note [First Bump] +-- If the lastTimestamp is zero, this is the first time a RateLimiter has been +-- bumped. In that case, always allow, then set the qps to the qpsLimit minus +-- enough room for (qpsLimit - 1) additional bumps. This means the RateLimiter +-- will allow qpsLimit bumps at time zero, then throttle at bump qpsLimit + 1. +-- Without this, time is required for the count to approach the decay rate, +-- resulting in an initial spike of allowed bumps. For example, a RateLimiter +-- configured to 1 qps with 600 s half-life would allow at least the first +-- 865 bumps before actually limiting. diff --git a/Data/RateLimiterMap.hs b/Data/RateLimiterMap.hs new file mode 100644 --- /dev/null +++ b/Data/RateLimiterMap.hs @@ -0,0 +1,167 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module Data.RateLimiterMap + ( -- * RateLimiterMap + RateLimiterMap + , newRateLimiterMap + , newRateLimiterMapWithKeyPreprocessor + , updateRateLimiterMapConfig + , rateLimitFilter + , whenAllowed + -- * Types + , Allowed(..) + , SampleWeight + -- * Primitives + , isAllowed + ) where + +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.IORef +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Atomics + +import Data.MovingAverageRateLimiter + +type Count = Int +type SampleWeight = Int + +-- | A 'RateLimiterMap' implements per-key rate limiting using +-- 'MovingAverageRateLimiter'. It is intentionally kept abstract. +data RateLimiterMap k = RateLimiterMap + { rlmRef :: {-# UNPACK #-} !(IORef (HashMap k (IORef RateLimitWithCount))) + , rlmConfig :: {-# UNPACK #-} !(IORef RateLimiterConfig) + , rlmKeyPreprocessor :: !(k -> IO k) + } + +-- Essentially a more strict and unboxed tuple. +data RateLimitWithCount = RateLimitWithCount {-# UNPACK #-} !Count !RateLimiter + +-- | Indicates whether key is rate-limited. +-- 'Allowed' carries a weight, which is the number of calls to +-- 'isAllowed' since the last time 'Allowed' was returned. +data Allowed = NotAllowed | Allowed {-# UNPACK #-} !SampleWeight + +-- | Create a new RateLimiterMap. +newRateLimiterMap + :: Double -- ^ QPS Limit + -> Double -- ^ Decay half-life, in seconds + -> IO (RateLimiterMap k) +newRateLimiterMap lim hl = newRateLimiterMapWithKeyPreprocessor lim hl return + +-- | Create a new RateLimiterMap with a preprocess provided, this preprocessor +-- is invoked before a key is inserted in the map. This may be needed in certain +-- scenarios when certain transformations need to be done on the keys before +-- they are inserted. +newRateLimiterMapWithKeyPreprocessor + :: Double -- ^ QPS Limit + -> Double -- ^ Decay half-life, in seconds + -> (k -> IO k) -- ^ Key preprocessor + -> IO (RateLimiterMap k) +newRateLimiterMapWithKeyPreprocessor lim hl keyPreprocessor = do + ref <- newIORef HashMap.empty + cfgRef <- newIORef $ mkRateLimiterConfig lim hl + return $ RateLimiterMap ref cfgRef keyPreprocessor + +-- | Change the configuration of a 'RateLimiterMap'. +-- This DOES NOT change the internal state of individual limiters. +-- It only changes the qps limit and decay rate that will be applied +-- to future rate-limit checks. +updateRateLimiterMapConfig + :: RateLimiterMap k + -> (RateLimiterConfig -> RateLimiterConfig) + -> IO () +updateRateLimiterMapConfig RateLimiterMap{..} f = + atomicModifyIORefCAS rlmConfig (\ c -> (f c, ())) + +-- | Rate-limit an action. +-- This is the preferred means of using a 'RateLimiterMap'. +whenAllowed + :: (Eq k, Hashable k) + => RateLimiterMap k + -> k + -> (SampleWeight -> IO ()) -- ^ If allowed, run this action + -> IO () +whenAllowed rlm k f = do + allowed <- isAllowed rlm k + case allowed of + NotAllowed -> return () + Allowed sw -> f sw + +-- | Filter association list by rate limiter. +-- Return all values whose keys pass the rate limiter. +rateLimitFilter + :: (Eq k, Hashable k) + => RateLimiterMap k + -> [(k, v)] + -> IO [(SampleWeight, v)] +rateLimitFilter rlm = go + where go [] = return [] + go ((k, v):kvs) = do + allowed <- isAllowed rlm k + case allowed of + NotAllowed -> go kvs + Allowed sw -> ((sw, v) :) <$> go kvs + +-- | Determine whether a new action is allowed by the 'RateLimiterMap'. +-- This check is *not* idempotent (it bumps the rate-limit counter). +-- The preferred means to rate-limit an action is with 'whenAllowed'. +isAllowed :: (Eq k, Hashable k) => RateLimiterMap k -> k -> IO Allowed +isAllowed RateLimiterMap{..} k = do + mbRL <- HashMap.lookup k <$> readIORef rlmRef + cfg <- readIORef rlmConfig + case mbRL of + Just ref -> allowCheck cfg ref + Nothing -> do + -- Key hasn't been seen, create a new IORef for it. + newRef <- newIORef $ RateLimitWithCount 0 mkRateLimiter + newKey <- rlmKeyPreprocessor k + -- Associate the IORef with the key. If its been added by + -- another thread, return that IORef instead. + newRef' <- atomicModifyIORefCAS rlmRef $ addOrReturnExisting newKey newRef + allowCheck cfg newRef' + +-- ---------------------------------------------------------------------------- +-- Internals + +-- | Run 'mutate' with the current time. +allowCheck :: RateLimiterConfig -> IORef RateLimitWithCount -> IO Allowed +allowCheck cfg rlRef = do + t <- realToFrac <$> getPOSIXTime + atomicModifyIORefCAS rlRef (mutate cfg t) + +-- | Wrapper around MovingAverageRateLimiter's 'allow' which also counts +-- how many times the check has been performed. This count is used as the +-- sample weight whenever 'Allowed' is returned. +mutate + :: RateLimiterConfig + -> Double -- ^ current timestamp + -> RateLimitWithCount + -> (RateLimitWithCount, Allowed) +mutate cfg t (RateLimitWithCount c rl) = + case allow cfg rl t of + (True , rl') -> (RateLimitWithCount 0 rl', Allowed (c+1)) + (False, rl') -> (RateLimitWithCount (c+1) rl', NotAllowed) + +-- | Meant to be called inside atomicModifyIORef. Attempts to insert into +-- the HashMap, but if the key is already set, returns the existing value +-- instead. This way several threads can race-to-insert, one will win, +-- and the rest will get a copy of the winner's value. +addOrReturnExisting + :: (Eq k, Hashable k) + => k + -> a + -> HashMap k a + -> (HashMap k a, a) +addOrReturnExisting k v m = + case HashMap.lookup k m of + Just v' -> (m, v') + Nothing -> (HashMap.insert k v m, v) diff --git a/Foreign/CPP/Addressable.hs b/Foreign/CPP/Addressable.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/Addressable.hs @@ -0,0 +1,107 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE DefaultSignatures #-} +module Foreign.CPP.Addressable + ( Addressable(..) + , Addressable1(..) + ) where + +import Data.Complex (Complex) +import Data.Ratio (Ratio) +import Data.Functor.Const (Const) +import Data.Functor.Identity (Identity) +import Foreign hiding (sizeOf, alignment) +import Foreign.C.Types +import qualified Foreign.Storable as Storable +import GHC.Fingerprint (Fingerprint) +import System.Posix.Types + +class Addressable a where + -- | Computes the storage requirements (in bytes) of the argument. + -- The value of the argument is not used. + sizeOf :: a -> Int + default sizeOf :: Storable a => a -> Int + sizeOf = Storable.sizeOf + + -- | Computes the alignment constraint of the argument. An alignment + -- constraint @x@ is fulfilled by any address divisible by @x@. + -- The value of the argument is not used. + alignment :: a -> Int + default alignment :: Storable a => a -> Int + alignment = Storable.alignment + +class Addressable1 f where + sizeOf1 :: f a -> Int + alignment1 :: f a -> Int + +instance Addressable Bool +instance Addressable Char +instance Addressable Double +instance Addressable Float +instance Addressable Int +instance Addressable Int8 +instance Addressable Int16 +instance Addressable Int32 +instance Addressable Int64 +instance Addressable Word +instance Addressable Word8 +instance Addressable Word16 +instance Addressable Word32 +instance Addressable Word64 +instance Addressable () +instance Addressable Fingerprint +instance Addressable CUIntMax +instance Addressable CIntMax +instance Addressable CUIntPtr +instance Addressable CIntPtr +instance Addressable CSUSeconds +instance Addressable CUSeconds +instance Addressable CTime +instance Addressable CClock +instance Addressable CSigAtomic +instance Addressable CWchar +instance Addressable CSize +instance Addressable CPtrdiff +instance Addressable CDouble +instance Addressable CFloat +instance Addressable CULLong +instance Addressable CLLong +instance Addressable CULong +instance Addressable CLong +instance Addressable CUInt +instance Addressable CInt +instance Addressable CUShort +instance Addressable CShort +instance Addressable CUChar +instance Addressable CSChar +instance Addressable CChar +instance Addressable CBool +instance Addressable IntPtr +instance Addressable WordPtr +instance Addressable Fd +instance Addressable CRLim +instance Addressable CTcflag +instance Addressable CSpeed +instance Addressable CCc +instance Addressable CUid +instance Addressable CNlink +instance Addressable CGid +instance Addressable CSsize +instance Addressable CPid +instance Addressable COff +instance Addressable CMode +instance Addressable CIno +instance Addressable CDev +instance (Storable a, Integral a) => Addressable (Ratio a) +instance Addressable (StablePtr a) +instance Addressable (Ptr a) +instance Addressable (FunPtr a) +instance Storable a => Addressable (Complex a) +instance Storable a => Addressable (Identity a) +instance Storable a => Addressable (Const a b) diff --git a/Foreign/CPP/Dynamic.hsc b/Foreign/CPP/Dynamic.hsc new file mode 100644 --- /dev/null +++ b/Foreign/CPP/Dynamic.hsc @@ -0,0 +1,332 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- +-- Marshal folly::dynamic directly into Haskell's Data.Aeson, +-- and in the other direction. +-- + +{-# LANGUAGE TemplateHaskell, QuasiQuotes, DeriveGeneric #-} + +{-# OPTIONS -fno-warn-unused-imports #-} -- broken on this module +module Foreign.CPP.Dynamic + ( Dynamic + , readDynamic + , readDynamicLenient + , createDynamic + , destroyDynamic + , withDynamic + , parseJSON + , parseJSONWithOptions + , JSONOptions(..) + , JSONParserFFI + , callJSONParserFFI + ) where + +import Control.Monad (when) +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe +import Data.Default +import qualified Data.ByteString as B +import Foreign.C +import Foreign hiding (alloca, allocaBytes, allocaArray) +-- Custom alloca and friends +import Util.Memory +import Util.ByteString +import GHC.Generics +import Data.Coerce + +import Control.Applicative ((<$>)) +import Control.Exception (bracket) +import Data.Aeson hiding (parseJSON) +import qualified Data.Vector as Vector +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Scientific + +import Mangle.TH +import Foreign.CPP.Marshallable.TH +import Util.Aeson +import Util.Text + ( cStringToText + , cStringToTextLenient + , useTextAsCString + , useTextsAsCStrings ) +import Util.String.Quasi + +-- | Phantom type for @folly::dynamic@ pointers. +newtype Dynamic = Dynamic + { unDynamic :: Value } + +$(deriveDestructibleUnsafe "Dynamic" [t| Dynamic |]) + +newtype DType = DType #{type DType} + deriving (Eq, Storable) + +#{enum DType, DType + , tNull = tNull + , tArray = tArray + , tBool = tBool + , tDouble = tDouble + , tInt64 = tInt64 + , tObject = tObject + , tString = tString + } + +$(mangle + [s| + void facebook::hs::readDynamic( + const folly::dynamic*, DType*, DValue*) + |] [d| + foreign import ccall unsafe + c_readDynamic :: Ptr Dynamic -> Ptr DType -> Ptr () -> IO () + |]) + +$(mangle + [s| + int facebook::hs::readDynamicArray( + const folly::dynamic*, size_t, const folly::dynamic**) + |] [d| + foreign import ccall unsafe + c_readDynamicArray :: Ptr Dynamic -> CSize + -> Ptr (Ptr Dynamic) + -> IO CInt + |]) + +$(mangle + [s| + int facebook::hs::readDynamicObject( + const folly::dynamic*, size_t, + const folly::dynamic**, const folly::dynamic**) + |] [d| + foreign import ccall unsafe + c_readDynamicObject :: Ptr Dynamic -> CSize + -> Ptr (Ptr Dynamic) + -> Ptr (Ptr Dynamic) + -> IO CInt + |]) + +$(mangle + "void facebook::hs::createDynamic(folly::dynamic*, DType, DValue*)" + [d| + foreign import ccall unsafe + c_createDynamic :: Ptr Dynamic -> DType -> Ptr () -> IO () + |]) + +$(mangle + [s| + void facebook::hs::createDynamicArray( + folly::dynamic*, size_t, folly::dynamic*) + |] [d| + foreign import ccall unsafe + c_createDynamicArray :: Ptr Dynamic -> CSize -> Ptr Dynamic -> IO () + |]) + +$(mangle + [s| + void facebook::hs::createDynamicObject( + folly::dynamic*, size_t, const char**, folly::dynamic*) + |] [d| + foreign import ccall unsafe + c_createDynamicObject :: Ptr Dynamic + -> CSize + -> Ptr CString + -> Ptr Dynamic + -> IO () + |]) + +$(mangle + "folly::dynamic* facebook::hs::parseJSON(const char*, int64_t, int, char **)" + [d| + foreign import ccall unsafe + c_parseJSON :: CString -> CLong -> CInt -> Ptr (Ptr CChar) + -> IO (Ptr Dynamic) + |]) + + +$(mangle + "folly::dynamic* facebook::hs::parseJSON(const char*, int64_t, int, char **)" + [d| + foreign import ccall safe + c_parseJSON_safe :: CString -> CLong -> CInt -> Ptr (Ptr CChar) + -> IO (Ptr Dynamic) + |]) + +-- | Reads a 'Dynamic' into an Aeson 'Value'. +-- +-- Dynamic objects can have any type as the key, whereas JSON has only +-- string keys. This shows up when a PHP array has been converted to a +-- @folly::dynamic@, which will be an object with integer keys. +-- Therefore here we convert integer keys to strings to make it valid +-- JSON. +readDynamic :: Ptr Dynamic -> IO Value +readDynamic p = unDynamic <$> peek p + +-- | Reads a 'Dynamic' into an Aeson 'Value' using lenient UTF-8 decoding. +readDynamicLenient :: Ptr Dynamic -> IO Value +readDynamicLenient p = unDynamic <$> peekImpl cStringToTextLenient p + +-- | Creates a 'Dynamic' from an Aeson 'Value'. +-- +-- Remember to call 'destroyDynamic' to free the memory. +createDynamic :: Value -> IO (Ptr Dynamic) +createDynamic v = new $ Dynamic v + +-- | Frees the memory owned by 'Dynamic' +destroyDynamic :: Ptr Dynamic -> IO () +destroyDynamic p = destruct p >> free p + +-- | Executes an 'IO' action with an Aeson 'Value' marshalled as a 'Dynamic' +withDynamic :: Value -> (Ptr Dynamic -> IO a) -> IO a +withDynamic v = bracket (createDynamic v) destroyDynamic + +newtype JSONOptions = JSONOptions + { json_recursionLimit :: Maybe Int + } + deriving Generic + +instance Default JSONOptions + +-- | Parse JSON using folly::parseJson(), which is typically about 2x +-- faster than Aeson's family of JSON parsing functions. +parseJSON :: ByteString -> IO (Either Text Value) +parseJSON = parseJSONWithOptions def + +type JSONParserFFI = CString -> CLong -> Ptr (Ptr CChar) -> IO (Ptr Dynamic) + +parseJSONWithOptions :: JSONOptions -> ByteString -> IO (Either Text Value) +parseJSONWithOptions JSONOptions{..} bs = callJSONParserFFI parserFFI bs + where + rec = maybe (-1) fromIntegral json_recursionLimit + parserFFI cstr clen = ffi cstr clen rec + ffi + -- conservative: 100K parses in about 0.2ms + | B.length bs > 10*1024 = c_parseJSON_safe + | otherwise = c_parseJSON + +callJSONParserFFI :: JSONParserFFI -> ByteString -> IO (Either Text Value) +callJSONParserFFI ffi bs = + unsafeUseAsCStringLen bs $ \(cstr, clen) -> + Foreign.with nullPtr $ \perr -> do + let + cleanup pdynamic = do + str <- peek perr + when (str /= nullPtr) $ free str + delete pdynamic + bracket + (ffi cstr (fromIntegral clen) perr) + cleanup $ \pdynamic -> do + if pdynamic == nullPtr + then fmap Left $ cStringToText =<< peek perr + else Right <$> readDynamic pdynamic + +#include + +peekImpl :: (CString -> IO Text) -> Ptr Dynamic -> IO Dynamic +peekImpl peekCString p = do + alloca $ \pty -> allocaBytes #{size DValue} $ \pval -> + let getDyn pdyn = do + c_readDynamic pdyn pty pval + ty <- peek pty + if + | ty == tNull -> return Null + | ty == tArray -> getDynArray pdyn + | ty == tBool -> do b <- peek (castPtr pval :: Ptr CInt) + return (Bool (b /= 0)) + | ty == tDouble -> do d <- peek (castPtr pval :: Ptr Double) + return (Number (fromFloatDigits d)) + | ty == tInt64 -> do i <- peek (castPtr pval :: Ptr Int64) + return (Number (fromIntegral i)) + | ty == tString -> do s <- peek (castPtr pval :: Ptr CString) + txt <- peekCString s + return (String txt) + | ty == tObject -> getDynObject pdyn + | otherwise -> error "Foreign.CPP.Dynamic: illegal key type" + + getDynKey pdyn = do + c_readDynamic pdyn pty pval + ty <- peek pty + if + | ty == tDouble -> do d <- peek (castPtr pval :: Ptr Double) + return $! Text.pack (show d) + | ty == tInt64 -> do i <- peek (castPtr pval :: Ptr Int64) + return $! Text.pack (show i) + | ty == tString -> do s <- peek (castPtr pval :: Ptr CString) + txt <- peekCString s + return txt + | otherwise -> error "Foreign.CPP.Dynamic: illegal key type" + + getDynArray pdyn = do + size <- peek (castPtr pval :: Ptr CSize) + allocaArray (fromIntegral size) $ \pelems -> do + -- could be much more efficient here + num <- c_readDynamicArray pdyn size pelems + elems <- peekArray (fromIntegral num) pelems + dyns <- mapM getDyn elems + return (Array (Vector.fromList dyns)) + + getDynObject pdyn = do + size <- peek (castPtr pval :: Ptr CSize) + allocaArray (fromIntegral size) $ \pkeys -> do + allocaArray (fromIntegral size) $ \pvals -> do + num <- c_readDynamicObject pdyn size pkeys pvals + let + go !i !obj + | i >= fromIntegral num = return (Object obj) + | otherwise = do + key <- peekElemOff pkeys i >>= getDynKey + val <- peekElemOff pvals i >>= getDyn + go (i+1) (insertKeyMap (keyFromText key) val obj) + + go 0 emptyKeyMap + in + Dynamic <$> getDyn p + +instance Storable Dynamic where + sizeOf _ = #{size folly::dynamic} + alignment _ = #{alignment folly::dynamic} + + peek = peekImpl cStringToText + + poke p v = do + allocaBytes #{size DValue} $ \pval -> + let putDyn' :: Storable a => Ptr Dynamic -> DType -> a -> IO () + putDyn' pdyn ty val = do + poke (castPtr pval) val + c_createDynamic pdyn ty pval + + putDyn pdyn Null = c_createDynamic pdyn tNull nullPtr + + putDyn pdyn (Bool b) = putDyn' pdyn tBool $ if b then 1 else 0 :: CInt + + putDyn pdyn (Number n) = + case floatingOrInteger n of + Left d -> putDyn' pdyn tDouble (d :: Double) + Right i -> putDyn' pdyn tInt64 (i :: Int64) + + putDyn pdyn (String s) = useTextAsCString s $ putDyn' pdyn tString + + putDyn pdyn (Array arr) = do + let size = Vector.length arr + withArray' size (map Dynamic $ Vector.toList arr) $ \pelems -> + c_createDynamicArray pdyn (fromIntegral $ size) pelems + + putDyn pdyn (Object obj) = do + let size = keyMapSize obj + (keys, vals) = unzip $ objectToList obj + useTextsAsCStrings (map keyToText keys) $ \pkeys -> + withArray' size (map Dynamic vals) $ \pvals -> + c_createDynamicObject pdyn (fromIntegral $ size) pkeys pvals + in + putDyn p $ unDynamic v + where + withArray' n a f = + allocaArray n $ \pa -> do + pokeArray pa a + f pa diff --git a/Foreign/CPP/HsStruct.hs b/Foreign/CPP/HsStruct.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/HsStruct.hs @@ -0,0 +1,19 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Foreign.CPP.HsStruct + ( coerce + , Addressable + , module Types + , module Utils + ) where + +import Data.Coerce +import Foreign.CPP.Addressable (Addressable) +import Foreign.CPP.HsStruct.Types as Types +import Foreign.CPP.HsStruct.Utils as Utils diff --git a/Foreign/CPP/HsStruct/HsArray.hs b/Foreign/CPP/HsStruct/HsArray.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/HsStruct/HsArray.hs @@ -0,0 +1,105 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} +module Foreign.CPP.HsStruct.HsArray + ( deriveHsArrayUnsafe + ) where + + +import Control.Monad (forM_) +import Data.Char (isAlphaNum) +import Data.Vector (forM_) +import Language.Haskell.TH + +import Foreign +import Foreign.C.Types (CSize) +import Foreign.CPP.Marshallable + + +deriveHsArrayUnsafe + :: String -> TypeQ -> Q [Dec] +deriveHsArrayUnsafe cppType hsType = do + arrayTypeStr <- + map (\i -> if isAlphaNum i then i else '_') . pprint <$> arrayType + + let + cppNewName = "vector_new" ++ cppName + hsNewName = mkName $ "c_vector_new" ++ arrayTypeStr + newImport <- forImpD cCall unsafe cppNewName hsNewName + [t| CSize -> IO (Ptr ()) |] + + let + cppConstructName = "vector_construct" ++ cppName + hsConstructName = mkName $ "c_vector_construct" ++ arrayTypeStr + constructImport <- forImpD cCall unsafe cppConstructName hsConstructName + [t| Ptr () -> CSize -> IO () |] + + let + cppAddName = "vector_add" ++ cppName + hsAddName = mkName $ "c_vector_add" ++ arrayTypeStr + addImport <- forImpD cCall unsafe cppAddName hsAddName + [t| Ptr () -> Ptr $hsType -> IO () |] + + hsT <- hsType + isDestructible <- isInstance (mkName "Destructible") [hsT] + + let + withFn = mkName $ if isDestructible then "withCxxObject" else "with" + + pN = mkName "p" + vsN = mkName "vs" + fromIntegralChunk = [| fromIntegral (length vs) |] + addChunk forMFn = + [| $forMFn vs $ \v -> + $(varE withFn) v $ \v_ptr -> + $(varE hsAddName) (castPtr p) v_ptr + |] + + newValueFn forMFn cType = funD (mkName "newValue") + [clause [conP (mkName cType) [varP vsN]] (normalB $ doE + [ bindS (varP pN) + [| castPtr <$> $(varE hsNewName) $(fromIntegralChunk)|] + , noBindS (addChunk forMFn) + , noBindS [| return p |] + ]) []] + + constructValueFn forMFn cType = funD (mkName "constructValue") + [clause [varP pN, conP (mkName cType) [varP vsN]] (normalB $ doE + [ noBindS [| $(varE hsConstructName) (castPtr p) $(fromIntegralChunk)|] + , noBindS (addChunk forMFn) + ]) []] + + + -- instance Constructible (HsList ) where + constructibleListInst <- instanceD + (cxt []) + [t| Constructible $listType |] + [ newValueFn [| Control.Monad.forM_ |] "HsList" + , constructValueFn [| Control.Monad.forM_ |] "HsList" + ] + + -- instance Constructible (HsArray ) where + constructibleArrayInst <- instanceD + (cxt []) + [t| Constructible $arrayType |] + [ newValueFn [| Data.Vector.forM_ |] "HsArray" + , constructValueFn [| Data.Vector.forM_ |] "HsArray" + ] + + return + [ constructibleListInst + , constructibleArrayInst + , newImport + , constructImport + , addImport + ] + where + listType = conT (mkName "HsList") `appT` hsType + arrayType = conT (mkName "HsArray") `appT` hsType + cppName = "HsArray" ++ cppType diff --git a/Foreign/CPP/HsStruct/HsMap.hs b/Foreign/CPP/HsStruct/HsMap.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/HsStruct/HsMap.hs @@ -0,0 +1,121 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Foreign.CPP.HsStruct.HsMap ( + deriveHsHashMapUnsafe, +) where + +import qualified Control.Monad +import Data.Char (isAlphaNum) +import qualified Data.HashMap.Strict as HashMap +import Language.Haskell.TH + +import Foreign (Ptr) +import Foreign.C.Types (CSize) +import Foreign.CPP.Marshallable + +-- HsHashMap ------------------------------------------------------------------- + +deriveHsHashMapUnsafe :: + String -> TypeQ -> TypeQ -> Q [Dec] +deriveHsHashMapUnsafe cppType hsKeyType hsValType = do + hashMapTypeStr <- + map (\i -> if isAlphaNum i then i else '_') . pprint + <$> hashMapType + + let cppConstructName = "map_construct" ++ cppName + hsConstructName = mkName $ "c_map_construct" ++ hashMapTypeStr + constructImport <- + forImpD + cCall + unsafe + cppConstructName + hsConstructName + [t|Ptr () -> CSize -> IO ()|] + + let cppAddName = "map_add" ++ cppName + hsAddName = mkName $ "c_map_add" ++ hashMapTypeStr + addImport <- + forImpD + cCall + unsafe + cppAddName + hsAddName + [t|Ptr () -> Ptr $hsKeyType -> Ptr $hsValType -> IO ()|] + + hsKT <- hsKeyType + hsVT <- hsValType + isKeyDestructible <- isInstance (mkName "Destructible") [hsKT] + isValDestructible <- isInstance (mkName "Destructible") [hsVT] + + let keyWithFn = mkName $ if isKeyDestructible then "withCxxObject" else "with" + valWithFn = mkName $ if isValDestructible then "withCxxObject" else "with" + pN = mkName "p" + hmN = mkName "hm" + addChunk = + [| + Control.Monad.forM_ (HashMap.toList hm) $ \(key, val) -> + $(varE keyWithFn) key $ \key_ptr -> + $(varE valWithFn) val $ \val_ptr -> + $(varE hsAddName) (castPtr p) key_ptr val_ptr + |] + + -- newValue (HsHashMap _h) = error "HsHashMap cannot be made on the heap" + newValueFn = + funD + (mkName "newValue") + [ clause + [conP (mkName "HsHashMap") [varP $ mkName "_h"]] + (normalB [|error "HsHashMap cannot be made on the heap"|]) + [] + ] + + -- constructValue p (HsHashMap hm) = do + -- $(varE hsConstructName) (castPtr p) (fromIntegral (length hm)) + -- Control.Monad.forM_ (toList hm) $ (\key, \val) -> + -- $(varE withKeyFn) key $ \key_ptr -> + -- $(varE withValFn) val $ \val_ptr -> + -- $(varE hsAddName) (castPtr p) key_ptr val_ptr + constructValueFn = + funD + (mkName "constructValue") + [ clause + [varP pN, conP (mkName "HsHashMap") [varP hmN]] + ( normalB $ + doE + [ noBindS + [| + $(varE hsConstructName) + (castPtr p) + (fromIntegral (length hm)) + |] + , noBindS addChunk + ] + ) + [] + ] + + -- instance Constructible (HsHashMap ) where + constructibleHashMapInst <- + instanceD + (cxt []) + [t|Constructible $hashMapType|] + [ newValueFn + , constructValueFn + ] + + return + [ constructibleHashMapInst + , constructImport + , addImport + ] + where + hashMapType = conT (mkName "HsHashMap") `appT` hsKeyType `appT` hsValType + cppName = "HsMap" ++ cppType diff --git a/Foreign/CPP/HsStruct/HsOption.hs b/Foreign/CPP/HsStruct/HsOption.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/HsStruct/HsOption.hs @@ -0,0 +1,160 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} +module Foreign.CPP.HsStruct.HsOption + ( HsOption(..) + , deriveHsOptionUnsafe + ) where + +import Data.Char (isAlphaNum) +import Foreign +import Language.Haskell.TH + +import Foreign.CPP.Addressable +import Foreign.CPP.Marshallable + +-- HsOption -------------------------------------------------------------------- + +newtype HsOption a = HsOption + { hsOption :: Maybe a + } + +-- | This is a Template Haskell function which is used in conjunction with +-- @HS_OPTION_H@ and @HS_OPTION_CPP@ from "HsOption.h" to generate instances for +-- `HsOption T` for your type `T` +deriveHsOptionUnsafe + :: String -> Int -> Int -> TypeQ -> Q [Dec] +deriveHsOptionUnsafe cppType sizeVal alignmentVal hsType = do + optionTypeStr <- + map (\i -> if isAlphaNum i then i else '_') . pprint <$> optionType + + -- instance Addressable (HsOption ) + addressableInst <- instanceD + (cxt []) + [t| Addressable $optionType |] + [] + + let + -- sizeOf _ = #{size DummyHsOption} + sizeOfFn = funD (mkName "sizeOf") + [ clause [wildP] (normalB $ litE $ integerL $ fromIntegral sizeVal) [] ] + + -- alignment _ = #{alignment DummyHsOption} + alignmentFn = funD (mkName "alignment") + [ clause [wildP] (normalB $ + litE $ integerL $ fromIntegral alignmentVal) [] + ] + + -- poke = error "HsOption not pokeable" + pokeFn = funD (mkName "poke") + [ clause [] (normalB $ + varE (mkName "error") `appE` + stringE (optionTypeStr ++ " not pokeable") + ) + [] + ] + + pN = mkName "p" + ptrN = mkName "ptr" + peekN = mkName "peek" + -- peek p = do + -- ptr <- peekByteOff p 0 -- assume beginning of struct + -- HsOption <$> maybePeek peek ptr + peekFn = funD peekN + [clause [varP pN] (normalB $ doE + [ bindS + (varP ptrN ) + (varE (mkName "peekByteOff") `appE` varE pN `appE` litE (integerL 0)) + , noBindS (infixApp + (conE $ mkName "HsOption") + (varE $ mkName "fmap") + (varE (mkName "maybePeek") `appE` varE peekN `appE` varE ptrN) + ) + ]) []] + + -- instance Storable (HsOption ) where + storableInst <- instanceD + (cxt []) + [t| Storable $optionType |] + [sizeOfFn, alignmentFn, pokeFn, peekFn] + + let + cppCtorName = "option_ctorHsOption" ++ cppType + -- cppCtor = "void " ++ cppCtorName ++ "(void*, " ++ cppType ++ "*)" + hsCtorName = mkName $ "c_ctor" ++ optionTypeStr + + -- foreign import ccall unsafe "" + -- c_ctor :: Ptr (HsOption ) -> Ptr -> IO () + ctorImport <- forImpD cCall unsafe cppCtorName hsCtorName + [t| Ptr $optionType -> Ptr $hsType -> IO () |] + + let + cppNewName = "option_newHsOption" ++ cppType + -- cppNew = "void* " ++ cppNewName ++ "(" ++ cppType ++ "*)" + hsNewName = mkName $ "c_new" ++ optionTypeStr + +-- foreign import ccall unsafe "" +-- c_new :: Ptr -> IO (Ptr (HsOption )) + newImport <- forImpD cCall unsafe cppNewName hsNewName + [t| Ptr $hsType -> IO (Ptr $optionType) |] + + hsT <- hsType + isDestructible <- isInstance (mkName "Destructible") [hsT] + + let + optN = mkName "HsOption" + nothingN = mkName "Nothing" + justN = mkName "Just" + vN = mkName "v" + + withFn = if isDestructible then "withCxxObject" else "with" + + -- newValue (HsOption Nothing) = newDefault + -- newValue (HsOption (Just v)) = + -- withCxxObject v $ c_newOption + newValueFn = funD (mkName "newValue") + [ clause [conP optN [conP nothingN []]] (normalB $ + varE (mkName "newDefault")) [], + clause [conP optN [conP justN [varP vN]]] (normalB $ + infixApp + (varE (mkName withFn) `appE` varE vN) + (varE (mkName "$")) + (varE hsNewName) + ) [] + ] + + -- constructValue p (HsOption Nothing) = constructDefault p + -- constructValue p (HsOption (Just v)) = + -- withCxxObject v $ c_ctorOption p + constructValueFn = funD (mkName "constructValue") + [ clause [varP pN, conP optN [conP nothingN []]] (normalB $ + varE (mkName "constructDefault") `appE` varE pN) [], + clause [varP pN, conP optN [conP justN [varP vN]]] (normalB $ + infixApp + (varE (mkName withFn) `appE` varE vN) + (varE (mkName "$")) + (varE hsCtorName `appE` varE pN) + ) [] + ] + + -- instance Constructible (HsOption ) where + constructibleInst <- instanceD + (cxt []) + [t| Constructible $optionType |] + [newValueFn, constructValueFn] + + return + [ addressableInst + , storableInst + , ctorImport + , newImport + , constructibleInst + ] + where + optionType = [t| HsOption $hsType |] diff --git a/Foreign/CPP/HsStruct/HsSet.hs b/Foreign/CPP/HsStruct/HsSet.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/HsStruct/HsSet.hs @@ -0,0 +1,116 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Foreign.CPP.HsStruct.HsSet ( + deriveHsHashSetUnsafe, +) where + +import qualified Control.Monad +import Data.Char (isAlphaNum) +import Language.Haskell.TH + +import Foreign (Ptr) +import Foreign.C.Types (CSize) +import Foreign.CPP.Marshallable + +-- HsHashSet ------------------------------------------------------------------- + +deriveHsHashSetUnsafe :: + String -> TypeQ -> Q [Dec] +deriveHsHashSetUnsafe cppType hsType = do + hashSetTypeStr <- + map (\i -> if isAlphaNum i then i else '_') . pprint + <$> hashSetType + + let cppConstructName = "set_construct" ++ cppName + hsConstructName = mkName $ "c_set_construct" ++ hashSetTypeStr + constructImport <- + forImpD + cCall + unsafe + cppConstructName + hsConstructName + [t|Ptr () -> CSize -> IO ()|] + + let cppAddName = "set_add" ++ cppName + hsAddName = mkName $ "c_set_add" ++ hashSetTypeStr + addImport <- + forImpD + cCall + unsafe + cppAddName + hsAddName + [t|Ptr () -> Ptr $hsType -> IO ()|] + + hsT <- hsType + isDestructible <- isInstance (mkName "Destructible") [hsT] + + let withFn = mkName $ if isDestructible then "withCxxObject" else "with" + pN = mkName "p" + keysN = mkName "keys" + + addChunk = + [| + Control.Monad.forM_ keys $ \key -> + $(varE withFn) key $ \key_ptr -> + $(varE hsAddName) (castPtr p) key_ptr + |] + + -- newValue (HsHashSet _h) = error "HsHashSet cannot be made on the heap" + newValueFn = + funD + (mkName "newValue") + [ clause + [conP (mkName "HsHashSet") [varP $ mkName "_h"]] + (normalB [|error "HsHashSet cannot be made on the heap"|]) + [] + ] + + -- constructValue (HsHashSet h) = do + -- $(varE hsConstructName) (castPtr p) (fromIntegral (length keys) + -- Control.Monad.forM_ keys $ \key -> + -- $(varE withFn) key $ \key_ptr -> + -- $(varE hsAddName) (castPtr p) key_ptr + constructValueFn = + funD + (mkName "constructValue") + [ clause + [varP pN, conP (mkName "HsHashSet") [varP keysN]] + ( normalB $ + doE + [ noBindS + [| + $(varE hsConstructName) + (castPtr p) + (fromIntegral (length keys)) + |] + , noBindS addChunk + ] + ) + [] + ] + + -- instance Constructible (HsHashSet ) where + constructibleHashSetInst <- + instanceD + (cxt []) + [t|Constructible $hashSetType|] + [ newValueFn + , constructValueFn + ] + + return + [ constructibleHashSetInst + , constructImport + , addImport + ] + where + hashSetType = conT (mkName "HsHashSet") `appT` hsType + cppName = "HsSet" ++ cppType diff --git a/Foreign/CPP/HsStruct/HsStdTuple.hs b/Foreign/CPP/HsStruct/HsStdTuple.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/HsStruct/HsStdTuple.hs @@ -0,0 +1,155 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} +module Foreign.CPP.HsStruct.HsStdTuple + ( deriveHsStdTupleUnsafe + , HsStdTuple(..) + ) where + +import Data.List (foldl') +import Control.Monad (forM, unless) +import Foreign +import Language.Haskell.TH + +import Foreign.CPP.Addressable +import Foreign.CPP.Marshallable + + +newtype HsStdTuple a = HsStdTuple { unHsStdTuple :: a } + +deriveHsStdTupleUnsafe + :: String -> Int -> Int -> TypeQ -> Q [Dec] +deriveHsStdTupleUnsafe cppType sizeVal alignmentVal hsType = do + hsStdTupleType <- [t| HsStdTuple |] + hsTRaw <- hsType + let + (hsT, tupleType) = case hsTRaw of + (AppT a b) | a == hsStdTupleType -> (b, hsType) + _ -> (hsTRaw, [t| HsStdTuple $hsType |]) + (numTypes, hsTypes) = unfoldTupleT hsT + + unless (numTypes > 0) $ + fail "StdTuple must be a tuple with 1 or more underlying types" + + hsTypesDestructible <- + forM hsTypes $ \t -> isInstance (mkName "Destructible") [t] + + addressableInst <- instanceD + (cxt []) + [t| Addressable $tupleType |] + [] + + let + sizeOfFn = funD (mkName "sizeOf") + [ clause [wildP] (normalB $ litE $ integerL $ fromIntegral sizeVal) [] ] + + alignmentFn = funD (mkName "alignment") + [ clause [wildP] (normalB $ + litE $ integerL $ fromIntegral alignmentVal) [] + ] + + ptrN = mkName "ptr" + pNames = take numTypes $ idxNames "p" + vNames = take numTypes $ idxNames "v" + pvZipped = zip pNames vNames + pCasted = map (\p -> parensE $ varE castPtrN `appE` varE p) pNames + + hsPokeName = mkName $ "c_poke_" ++ cppName + cppPokeName = "std_tuple_poke_" ++ cppName + + nestedPokeFns = nestPokeFns (zip3 vNames pNames hsTypesDestructible) $ doE + -- c_poke* FFI call + [ noBindS (foldl' appE + (varE hsPokeName `appE` [| castPtr ptr|] `appE` [|nullPtr|]) + pCasted + ) + ] + + pokeFn = funD (mkName "poke") + [ clause [varP ptrN, conP (mkName "HsStdTuple") [tupP (map varP vNames)]] + (normalB nestedPokeFns) [] + ] + + hsPeekName = mkName $ "c_peek_" ++ cppName + cppPeekName = "std_tuple_peek_" ++ cppName + + nestedPeekFns = nestPeekFns (zip pNames hsTypesDestructible) $ + doE $ + -- c_peek* FFI call + [noBindS (foldl' appE + (varE hsPeekName `appE` [| castPtr ptr|] `appE` [|nullPtr|]) + pCasted + ) + ] ++ + -- N peeks + map (\(p, v) -> bindS (varP v) (varE (mkName "peek") `appE` varE p)) + pvZipped ++ + -- tuple construction + [noBindS (varE (mkName "return") `appE` + parensE (conE (mkName "HsStdTuple") `appE` tupE (map varE vNames))) + ] + + peekFn = funD (mkName "peek") + [ clause [varP ptrN] (normalB nestedPeekFns) [] + ] + + storableInst <- instanceD + (cxt []) + [t| Storable $tupleType |] + [sizeOfFn, alignmentFn, pokeFn, peekFn] + + peekImport <- forImpD cCall unsafe cppPeekName hsPeekName $ + -- Ptr () -> Ptr () -> <<< all tuple types >>> -> IO () + foldl' (\b a -> [t| $a -> $b |]) [t| IO () |] $ + map (\a -> [t| Ptr $a |]) ([t|()|] : [t| ()|] : map return hsTypes) + + pokeImport <- forImpD cCall unsafe cppPokeName hsPokeName $ + -- Ptr () -> Ptr () -> <<< all tuple types >>> -> IO () + foldl' (\b a -> [t| $a -> $b |]) [t| IO () |] $ + map (\a -> [t| Ptr $a |]) ([t|()|] : [t| ()|] : map return hsTypes) + + constructibleInst <- instanceD + (cxt []) + [t| Constructible $tupleType |] + [] + + return + [ addressableInst + , storableInst + , constructibleInst + , peekImport + , pokeImport + ] + where + unfoldTupleT :: Type -> (Int, [Type]) + unfoldTupleT (AppT a b) = let + (i, ts) = unfoldTupleT a + in (i, ts ++ [b]) + unfoldTupleT (TupleT i) = (i, []) + unfoldTupleT n = (1, [n]) + + castPtrN = mkName "castPtr" + cppName = cppType + + idxNames c = map (\i -> mkName (c ++ show i)) [0::Int ..] + + nestPeekFns :: [(Name, Bool)] -> ExpQ -> ExpQ + nestPeekFns [] base = base + nestPeekFns ((p, isDestructible):ts) base = + varE (mkName allocFn) `appE` lamE [varP p] (nestPeekFns ts base) + where + allocFn = if isDestructible then "withDefaultCxxObject" else "alloca" + + nestPokeFns :: [(Name, Name, Bool)] -> ExpQ -> ExpQ + nestPokeFns [] base = base + nestPokeFns ((v, p, isDestructible):ts) base = + varE (mkName withObjFn) `appE` varE v `appE` + lamE [varP p] (nestPokeFns ts base) + where + withObjFn = if isDestructible then "withCxxObject" else "with" diff --git a/Foreign/CPP/HsStruct/HsStdVariant.hs b/Foreign/CPP/HsStruct/HsStdVariant.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/HsStruct/HsStdVariant.hs @@ -0,0 +1,153 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Foreign.CPP.HsStruct.HsStdVariant + ( deriveHsStdVariantUnsafe + ) where + +import Language.Haskell.TH + +import Foreign +import Foreign.C.Types +import Foreign.CPP.Addressable +import Foreign.CPP.Marshallable + +deriveHsStdVariantUnsafe + :: String -> Int -> Int -> String -> TypeQ -> Q [Dec] +deriveHsStdVariantUnsafe cppName sizeVal alignmentVal hsName hsType = do + typeName <- do + v <- lookupTypeName hsName + case v of + Just val -> return val + Nothing -> fail ("Unable to find type " ++ hsName) + -- Get the constructors from the data type + constructors <- do + info <- reify typeName + case info of + -- start zip from `1` since `0` corresponds to `monostate` + TyConI (DataD _ _ _ _ cons' _) -> return $ zip [1..] cons' + _ -> fail ("Unsupported type for HsStdVariant " ++ hsName) + + addressableInst <- instanceD + (cxt []) + [t| Addressable $hsType |] + [] + + let (cppPeekValName, hsPeekValName) = importNames "peek" + peekValImport <- forImpD cCall unsafe cppPeekValName hsPeekValName + [t| Ptr () -> Ptr CInt -> IO (Ptr ()) |] + + let (cppPokeValName, hsPokeValName) = importNames "poke" + pokeValImport <- forImpD cCall unsafe cppPokeValName hsPokeValName + [t| Ptr () -> Ptr () -> CInt -> IO () |] + + (peekMatches, pokeClauses) <- + unzip <$> mapM (getConData hsPokeValName) constructors + + -- Storable + let + sizeOfFn = funD (mkName "sizeOf") + [ clause [wildP] (normalB $ litE $ integerL $ fromIntegral sizeVal) [] ] + + alignmentFn = funD (mkName "alignment") + [ clause [wildP] (normalB $ + litE $ integerL $ fromIntegral alignmentVal) [] + ] + + pokeFn = funD (mkName "poke") pokeClauses + + idxN = mkName "idx" + idxpN = mkName "idx_p" + peekN = mkName "peek" + + -- Peek by calling `hsPeekValName` to extract idx and ptr + -- Unknown returned index results in `error` + peekFn = funD peekN + [clause [varP pN] + (normalB $ varE (mkName "alloca") `appE` lamE [varP idxpN] (doE + [ bindS + (varP valpN) + (varE hsPeekValName `appE` + parensE (varE castPtrN `appE` varE pN) `appE` + varE idxpN) + , bindS (varP idxN) (varE peekN `appE` varE idxpN) + , noBindS (caseE (varE idxN) (peekMatches ++ + [ match wildP (normalB $ + varE (mkName "error") `appE` parensE + (infixApp + (stringE ("Unable to peek " ++ hsName ++ " with index ")) + (varE $ mkName "++") + (varE (mkName "show") `appE` varE idxN) + ) + ) [] + ]) + ) + ])) [] + ] + + storableInst <- instanceD + (cxt []) + [t| Storable $hsType |] + [sizeOfFn, alignmentFn, pokeFn, peekFn] + + + -- Constructible + constructibleInst <- instanceD + (cxt []) + [t| Constructible $hsType |] + [] + + return + [ addressableInst + , constructibleInst + , peekValImport + , pokeValImport + , storableInst + ] + where + pN = mkName "p" + castPtrN = mkName "castPtr" + valpN = mkName "__val_p" + + importNames pre = ("std_variant_" ++ base, mkName $ "c_" ++ base) + where + base = pre ++ cppName + + getConData hsPokeName (idx, NormalC name [(_, t)] ) = do + isDestructible <- isInstance (mkName "Destructible") [t] + + let + -- A match clause for the given index, using the constructor `name` + -- after `peek`ing the result + peekMatch = match (litP $ integerL idx) (normalB $ infixApp + (conE name) + (varE $ mkName "fmap") + (varE (mkName "peek") `appE` parensE (varE castPtrN `appE` + varE valpN)) + ) + [] + + let + valN = mkName "__val" + withObjFn = if isDestructible then "withCxxObject" else "with" + -- Matching against the particular constructor `name`, + -- Using with/withCxxObject to get a pointer to the underlying data + -- to send down + pokeClause = clause [varP pN, conP name [varP valN]] (normalB $ + varE (mkName withObjFn) `appE` varE valN `appE` lamE [varP valpN] ( + varE hsPokeName `appE` + parensE (varE castPtrN `appE` varE pN) `appE` + parensE (varE castPtrN `appE` varE valpN) `appE` + litE (integerL idx) + )) + [] + + return (peekMatch, pokeClause) + getConData _ _ = fail "Only take unnamed constructors with 1 type" diff --git a/Foreign/CPP/HsStruct/Types.hsc b/Foreign/CPP/HsStruct/Types.hsc new file mode 100644 --- /dev/null +++ b/Foreign/CPP/HsStruct/Types.hsc @@ -0,0 +1,999 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Foreign.CPP.HsStruct.Types + ( StorableContainer(..) + -- * HsRange + , HsRange(..) + , HsStringPiece + , withByteStringAsHsStringPiece + , withTextAsHsStringPiece + -- * HsMaybe + , HsMaybe(..) + -- * HsOption + , HsOption(..) + -- * HsEither + , HsEither(..) + , peekHsEitherWith + -- * HsPair + , HsPair(..) + , peekHsPairWith + -- * HsStdTuple + , HsStdTuple(..) + -- * HsString + , HsString(..) + , HsByteString(..) + , HsText(..) + , HsLenientText(..) + -- * HsArray + , HsArray(..) + , HsArrayStorable(..) + , HsList(..) + -- * HsMap + , HsMap(..) + , HsIntMap(..) + , HsHashMap(..) + , HsObject(..) + , HsHashSet(..) + -- * HsJSON + , HsJSON(..) + ) where + +import Control.DeepSeq (NFData) +import Data.Aeson (Value(..)) +import Data.ByteString (ByteString, packCStringLen) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Hashable (Hashable, hashWithSalt) +import Data.Text (Text) +import qualified Data.Text.Encoding as Text (encodeUtf8) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashSet as HashSet +import Data.IntMap.Strict (IntMap) +import Data.Map.Strict (Map) +import Data.Scientific + (fromFloatDigits, floatingOrInteger, toBoundedInteger, toRealFloat) +import Data.Vector (Vector, generateM) +import qualified Data.Vector.Storable as VS +import qualified Data.Vector as Vector +import Foreign hiding (void) +import Foreign.C +import qualified Data.HashMap.Strict as HashMap +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map + +import Foreign.CPP.Addressable hiding (alignment, sizeOf) +import qualified Foreign.CPP.Addressable as Addressable +import Foreign.CPP.HsStruct.HsArray +import Foreign.CPP.HsStruct.HsSet +import Foreign.CPP.HsStruct.HsMap +import Foreign.CPP.HsStruct.HsOption +import Foreign.CPP.HsStruct.HsStdTuple +import Foreign.CPP.HsStruct.Utils +import Foreign.CPP.Marshallable.TH +import Mangle.TH +import Util.Aeson +import Util.FFI +import Util.Text (cStringLenToText, cStringLenToTextLenient) + +#include +#include +#include +#include +#include + +-- | An abstraction over storable containers. The elements will be marshaled or +-- interpreted by given function. The element type must be 'Addressable' +-- (with 'sizeOf' and 'alignment' defined) in order to use 'peekWith' and +-- 'pokeWith'. +-- +-- Compared with creating a newtype for the element type, it will avoid +-- * duplicate identical implementation of 'sizeOf' and 'pokeWith' +-- * a trivial newtype unwrapping +-- * an unsafe 'castPtr' in some cases +-- while introduce some risk of using wrong marshalers. +class StorableContainer f where + -- | Given a function to read each element, reads the whole container from + -- the specified memory location + peekWith :: Addressable a => (Ptr a -> IO b) -> Ptr (f a) -> IO (f b) + -- | Given a function to write each element, writes the whole container to + -- the specified memory location + pokeWith + :: Addressable a => (Ptr a -> b -> IO ()) -> Ptr (f a) -> f b -> IO () + +-- The default way to read and write a container. Require 'peek'/'poke' for +-- element type being implemented to use 'peek'/'poke' for the whole container. +instance {-# OVERLAPPABLE #-} + (Addressable1 f, StorableContainer f, Addressable a, Storable a) => + Storable (f a) where + sizeOf = sizeOf1 + alignment = alignment1 + peek = peekWith peek + poke = pokeWith poke + +peekElemOffWith :: forall a b. Addressable a + => (Ptr a -> IO b) -> Ptr a -> Int -> IO b +peekElemOffWith f p i = f $ p `plusPtr` (i * offset) + where + offset = Addressable.sizeOf (undefined :: a) + +notPokeable :: String -> a +notPokeable t = error $ "HsStruct." <> t <> " is not HS_POKEABLE" + +-- HsRange -------------------------------------------------------------------- + +data HsRange a n = HsRange (Ptr a) n + +instance Integral n => Storable (HsRange a n) where + sizeOf _ = #{size DummyHsRange} + alignment _ = #{alignment DummyHsRange} + peek p = do + (a :: Ptr a) <- #{peek DummyHsRange, a} p + (n :: CSize) <- #{peek DummyHsRange, n} p + return $ HsRange a $ fromIntegral n + poke p (HsRange a n) = do + #{poke DummyHsRange, a} p a + #{poke DummyHsRange, n} p (fromIntegral n :: CSize) + +type HsStringPiece = HsRange CChar Int + +$(mangle + "void ctorHsStringPiece(HsRange*, const char*, size_t)" + [d| + foreign import ccall unsafe + c_constructHsStringPiece :: Ptr HsStringPiece -> CString -> Word -> IO () + |]) + +$(mangle + "HsStringPiece* newHsStringPiece(const char*, size_t)" + [d| + foreign import ccall unsafe + c_newHsStringPiece :: CString -> Word -> IO (Ptr HsStringPiece) + |]) + +instance Constructible HsStringPiece where + newValue (HsRange str len) = + castPtr <$> c_newHsStringPiece str (fromIntegral len) + constructValue p (HsRange str len) = + c_constructHsStringPiece (castPtr p) str (fromIntegral len) + +instance Addressable HsStringPiece + +withByteStringAsHsStringPiece + :: ByteString -> (HsStringPiece -> IO res) -> IO res +withByteStringAsHsStringPiece b act = unsafeUseAsCStringLen b $ \cstrlen -> + act (uncurry HsRange cstrlen) + +withTextAsHsStringPiece :: Text -> (HsStringPiece -> IO res) -> IO res +withTextAsHsStringPiece b = withByteStringAsHsStringPiece (Text.encodeUtf8 b) + +-- HsMaybe -------------------------------------------------------------------- + +newtype HsMaybe a = HsMaybe + { hsMaybe :: Maybe a + } + +instance Addressable1 HsMaybe where + sizeOf1 _ = #{size DummyHsMaybe} + alignment1 _ = #{alignment DummyHsMaybe} + +instance Addressable (HsMaybe a) where + sizeOf = sizeOf1 + alignment = alignment1 + +instance StorableContainer HsMaybe where + pokeWith = notPokeable "HsMaybe" + peekWith f p = do + ptr <- #{peek DummyHsMaybe, ptr} p + HsMaybe <$> maybePeek f ptr + +-- HsString ------------------------------------------------------------------- + +newtype HsString = HsString + { hsString :: String + } + +$(mangle + "void ctorHsString(HsString*, const char*, size_t)}" + [d| + foreign import ccall unsafe + c_constructHsString :: Ptr HsString -> CString -> Word -> IO () + |]) + +$(mangle + "HsString* newHsString(const char*, size_t)}" + [d| + foreign import ccall unsafe + c_newHsString :: CString -> Word -> IO (Ptr HsString) + |]) + +instance Addressable HsString + +instance Storable HsString where + sizeOf _ = #{size HsString} + alignment _ = #{alignment HsString} + poke = notPokeable "HsString" + peek p = fmap HsString $ peekCStringLen =<< peekStrLen p + +peekStrLen :: Ptr a -> IO CStringLen +peekStrLen p = do + (str :: CString) <- #{peek HsString, str} p + (len :: CSize) <- #{peek HsString, len} p + return (str, fromIntegral len) + +newStrImpl :: ByteString -> IO (Ptr a) +newStrImpl bs = castPtr <$> (unsafeUseAsCStringLen bs $ \(str, len) -> + c_newHsString str (fromIntegral len)) + +constructStrImpl :: Ptr a -> ByteString -> IO () +constructStrImpl p bs = unsafeUseAsCStringLen bs $ \(str, len) -> + c_constructHsString (castPtr p) str (fromIntegral len) + +-- HsText --------------------------------------------------------------- + +newtype HsText = HsText + { hsText :: Text + } + +instance Addressable HsText where + sizeOf _ = #{size HsString} + alignment _ = #{alignment HsString} + +instance Constructible HsText where + newValue (HsText txt) = newStrImpl (Text.encodeUtf8 txt) + constructValue p (HsText txt) = + constructStrImpl (castPtr p) (Text.encodeUtf8 txt) + +instance Storable HsText where + sizeOf _ = #{size HsString} + alignment _ = #{alignment HsString} + poke = error "HsStruct.HsText: poke not implemented" + peek p = fmap HsText $ uncurry cStringLenToText =<< peekStrLen p + +instance Eq HsText where + (HsText a) == (HsText b) = a == b + +instance Hashable HsText where + hashWithSalt i (HsText a) = hashWithSalt i a + +-- HsEither ------------------------------------------------------------------- + +#{enum HsEitherTag, HsEitherTag + , hs_Left = HS_LEFT + , hs_Right = HS_RIGHT + } + +newtype HsEitherTag = HsEitherTag #{type HsEitherTag} + deriving (Eq, Storable) + +newtype HsEither a b = HsEither + { hsEither :: Either a b + } deriving NFData + +$(mangle + "void* newHsEither(HsEitherTag, void*)}" + [d| + foreign import ccall unsafe + c_newHsEither :: HsEitherTag -> Ptr c -> IO (Ptr (HsEither a b)) + |]) + +instance Addressable1 (HsEither a) where + sizeOf1 _ = #{size DummyHsEither} + alignment1 _ = #{alignment DummyHsEither} + +instance Addressable (HsEither a b) where + sizeOf = sizeOf1 + alignment = alignment1 + +instance Storable a => StorableContainer (HsEither a) where + pokeWith = notPokeable "HsEither" + peekWith = peekHsEitherWith peek + +peekHsEitherWith + :: (Ptr a -> IO x) + -> (Ptr b -> IO y) + -> Ptr (HsEither a b) + -> IO (HsEither x y) +peekHsEitherWith peekLeft peekRight p = do + isLeft <- #{peek DummyHsEither, isLeft} p :: IO CChar + if toBool isLeft + then do + ptr <- #{peek DummyHsEither, left} p + HsEither . Left <$> peekLeft ptr + else do + ptr <- #{peek DummyHsEither, right} p + HsEither . Right <$> peekRight ptr + +instance (Constructible a, Constructible b) + => Constructible (HsEither a b) where + newValue (HsEither (Left a)) = do + p_left <- newValue a + c_newHsEither hs_Left p_left + newValue (HsEither (Right b)) = do + p_right <- newValue b + c_newHsEither hs_Right p_right + + constructValue p (HsEither (Left a)) = do + p_left <- newValue a + #{poke DummyHsEither, isLeft} p (fromIntegral (1::Int) :: CBool) + #{poke DummyHsEither, left} p p_left + constructValue p (HsEither (Right b)) = do + #{poke DummyHsEither, isLeft} p (fromIntegral (0::Int) :: CBool) + p_right <- newValue b + #{poke DummyHsEither, right} p p_right + +-- HsPair --------------------------------------------------------------------- + +newtype HsPair a b = HsPair + { hsPair :: (a, b) + } + +instance Addressable1 (HsPair a) where + sizeOf1 _ = #{size DummyHsPair} + alignment1 _ = #{alignment DummyHsPair} + +instance Addressable (HsPair a b) where + sizeOf = sizeOf1 + alignment = alignment1 + +instance Storable a => StorableContainer (HsPair a) where + pokeWith = notPokeable "HsPair" + peekWith = peekHsPairWith peek + +peekHsPairWith + :: (Ptr a -> IO x) + -> (Ptr b -> IO y) + -> Ptr (HsPair a b) + -> IO (HsPair x y) +peekHsPairWith peekFirst peekSecond p = do + ptr_a <- #{peek DummyHsPair, fst_} p + fs <- peekFirst ptr_a + ptr_b <- #{peek DummyHsPair, snd_} p + sn <- peekSecond ptr_b + return $ HsPair (fs, sn) + +-- HsByteString --------------------------------------------------------------- + +newtype HsByteString = HsByteString + { hsByteString :: ByteString + } deriving NFData + +instance Addressable HsByteString where + sizeOf _ = #{size HsString} + alignment _ = #{alignment HsString} + +instance Constructible HsByteString where + newValue (HsByteString bs) = newStrImpl bs + constructValue p (HsByteString bs) = constructStrImpl (castPtr p) bs + +instance Storable HsByteString where + sizeOf _ = #{size HsString} + alignment _ = #{alignment HsString} + poke = notPokeable "HsByteString" + peek p = fmap HsByteString $ packCStringLen =<< peekStrLen p + +instance Eq HsByteString where + (HsByteString a) == (HsByteString b) = a == b + +instance Hashable HsByteString where + hashWithSalt i (HsByteString a) = hashWithSalt i a + +-- HsLenientText -------------------------------------------------------------- + +newtype HsLenientText = HsLenientText + { hsLenientText :: Text + } deriving (Eq, Hashable) + +instance Addressable HsLenientText + +instance Constructible HsLenientText where + newValue (HsLenientText txt) = newStrImpl (Text.encodeUtf8 txt) + constructValue p (HsLenientText txt) = + constructStrImpl (castPtr p) (Text.encodeUtf8 txt) + +instance Storable HsLenientText where + sizeOf _ = #{size HsString} + alignment _ = #{alignment HsString} + poke = notPokeable "HsLenientText" + peek p = fmap HsLenientText $ uncurry cStringLenToTextLenient =<< peekStrLen p + +-- HsArray +newtype HsArray a = HsArray + { hsArray :: Vector a + } + +instance Addressable1 HsArray where + sizeOf1 _ = #{size DummyHsArray} + alignment1 _ = #{alignment DummyHsArray} + +instance Addressable (HsArray a) where + sizeOf = sizeOf1 + alignment = alignment1 + +instance StorableContainer HsArray where + pokeWith = notPokeable "HsArray" + peekWith f p = do + (a, n) <- peekDataSize p + fmap HsArray . generateM n $ \i -> peekElemOffWith f a i + +-- | 'HsArrayStorable' is 'HsArray' with a more efficient +-- representation, which can be passed back out to C++ without copying +-- using Vector.Storable.unsafeWith. +newtype HsArrayStorable a = HsArrayStorable + { hsArrayStorable :: VS.Vector a + } + +instance Storable a => Storable (HsArrayStorable a) where + sizeOf _ = #{size DummyHsArray} + alignment _ = #{alignment DummyHsArray} + poke = notPokeable "HsArrayStorable" + peek p = do + (a, n) <- peekDataSize p + arr <- mallocForeignPtrArray n + unsafeWithForeignPtr arr $ \parr -> copyBytes parr a (n * sizeOf (undefined :: a)) + return (HsArrayStorable (VS.unsafeFromForeignPtr0 arr n)) + +-- HsList +newtype HsList a = HsList + { hsList :: [a] + } + +instance Addressable1 HsList where + sizeOf1 _ = #{size DummyHsArray} + alignment1 _ = #{alignment DummyHsArray} + +instance Addressable (HsList a) where + sizeOf = sizeOf1 + alignment = alignment1 + +instance StorableContainer HsList where + pokeWith = notPokeable "HsList" + peekWith f p = do + (a, n) <- peekDataSize p + let go !i !acc + | i < 0 = return acc + | otherwise = do + e <- peekElemOffWith f a i + go (i-1) (e:acc) + HsList <$> go (n-1) [] + +peekDataSize :: Ptr b -> IO (Ptr a, Int) +peekDataSize p = do + (a :: Ptr a) <- #{peek DummyHsArray, a} p + (n :: CSize) <- #{peek DummyHsArray, n} p + return (a, fromIntegral n) + +-- HsSet +newtype HsHashSet a = HsHashSet + -- Contains a List as a transport for the internal datatype that may not be + -- immediately hashable in haskell (i.e. CLong is not hashable, but the end + -- type of Int is) + { hsHashSet :: HashSet.HashSet a + } + +instance Addressable1 HsHashSet where + sizeOf1 = setSizeOf + alignment1 = setAlignment + +instance Addressable (HsHashSet a) where + sizeOf = sizeOf1 + alignment = alignment1 + +instance (Addressable a, Eq a, Hashable a, Storable a) + => Storable (HsHashSet a) where + sizeOf = sizeOf1 + alignment = alignment1 + poke = notPokeable "HsHashSet" + peek p = HsHashSet <$> peekSetWith HashSet.empty HashSet.insert peek p + +{-# INLINE peekSetWith #-} +peekSetWith + :: (Addressable a) + => s + -> (k -> s -> s) + -> (Ptr a -> IO k) + -> Ptr b + -> IO s +peekSetWith empty insert f p = do + (a :: Ptr a) <- #{peek DummyHsSet, keys} p + (n :: Int) <- (fromIntegral :: CSize -> Int) <$> #{peek DummyHsSet, n} p + let go !i !hs + | i >= n = return hs + | otherwise = do + k <- peekElemOffWith f a i + go (i + 1) $ insert k hs + go 0 empty + +setSizeOf, setAlignment :: a -> Int +setSizeOf _ = #{size DummyHsSet} +setAlignment _ = #{alignment DummyHsSet} + +-- HsMap +newtype HsMap k v = HsMap + { hsMap :: Map k v + } + +instance Addressable1 (HsMap k) where + sizeOf1 = mapSizeOf + alignment1 = mapAlignment + +instance Addressable (HsMap k v) where + sizeOf = sizeOf1 + alignment = alignment1 + +instance (Addressable k, Ord k, Storable k) => StorableContainer (HsMap k) where + pokeWith = notPokeable "HsMap" + peekWith f p = HsMap <$> peekMapWith Map.empty Map.insert peek f p + +newtype HsIntMap v = HsIntMap + { hsIntMap :: IntMap v + } + +instance Addressable1 HsIntMap where + sizeOf1 = mapSizeOf + alignment1 = mapAlignment + +instance Addressable (HsIntMap v) where + sizeOf = sizeOf1 + alignment = alignment1 + +instance StorableContainer HsIntMap where + pokeWith = notPokeable "HsIntMap" + peekWith f p = HsIntMap <$> peekMapWith IntMap.empty IntMap.insert peek f p + +newtype HsHashMap k v = HsHashMap + { hsHashMap :: HashMap k v + } + +instance Addressable1 (HsHashMap k) where + sizeOf1 = mapSizeOf + alignment1 = mapAlignment + +instance Addressable (HsHashMap k v) where + sizeOf = sizeOf1 + alignment = alignment1 + +instance (Addressable k, Eq k, Hashable k, Storable k) + => StorableContainer (HsHashMap k) where + pokeWith = notPokeable "HsHashMap" + peekWith f p = HsHashMap <$> peekMapWith HashMap.empty HashMap.insert peek f p + +newtype HsObject v = HsObject + { hsObject :: KeyMap v + } + +instance Addressable1 HsObject where + sizeOf1 = mapSizeOf + alignment1 = mapAlignment + +instance Addressable (HsObject v) where + sizeOf = sizeOf1 + alignment = alignment1 + +instance StorableContainer HsObject where + pokeWith = notPokeable "HsObject" + peekWith f p = HsObject <$> peekMapWith emptyKeyMap insertKeyMap fk f p + where + fk = fmap (keyFromText . hsText) . peek + +mapSizeOf, mapAlignment :: a -> Int +mapSizeOf _ = #{size DummyHsObject} +mapAlignment _ = #{alignment DummyHsObject} + +foreign import ccall unsafe "common_hs_ctorHsObjectJSON" + c_constructHsObjectJSON + :: Ptr (HsObject HsJSON) + -> Ptr (HsArray HsText) + -> Ptr (HsArray HsJSON) + -> IO () + +{-# INLINE peekMapWith #-} +peekMapWith + :: (Addressable a, Addressable b) + => m + -> (k -> v -> m -> m) + -> (Ptr a -> IO k) + -> (Ptr b -> IO v) + -> Ptr c + -> IO m +peekMapWith empty insert fk fv p = do + size <- (fromIntegral :: CSize -> Int) <$> #{peek DummyHsObject, n} p + keys <- #{peek DummyHsObject, keys} p + values <- #{peek DummyHsObject, values} p + let go !i !hm + | i >= size = return hm + | otherwise = do + k <- peekElemOffWith fk keys i + v <- peekElemOffWith fv values i + go (i+1) $ insert k v hm + go 0 empty + +-- HsJSON +newtype HsJSON = HsJSON + { hsJSON :: Value + } + +instance Addressable HsJSON + +instance Storable HsJSON where + sizeOf _ = #{size HsJSON} + alignment _ = #{alignment HsJSON} + poke = notPokeable "HsJSON" + peek p = do + (t :: CInt) <- #{peek HsJSON, type} p + #{let json_type t = "%d", static_cast(HsJSON::Type::t)} + HsJSON <$> case t of + #{json_type Null} -> + return Null + #{json_type Bool} -> + Bool . toBool <$> peekIntegral + #{json_type Integral} -> + Number . fromIntegral <$> peekIntegral + #{json_type Real} -> + Number . fromFloatDigits <$> (#{peek HsJSON, real} p :: IO CDouble) + #{json_type String} -> + String . hsText <$> #{peek HsJSON, string} p + #{json_type Array} -> + Array . fmap hsJSON . hsArray <$> #{peek HsJSON, array} p + #{json_type Object} -> + Object . fmap hsJSON . hsObject <$> #{peek HsJSON, object} p + _ -> + error "HsStruct.HsJSON: invalid HsJSON::Type" + where + peekIntegral = #{peek HsJSON, integral} p :: IO CLong + +$(mangle + "void ctorHsJSONNull(HsJSON*)" + [d| + foreign import ccall unsafe + c_constructHsJSONNull :: Ptr HsJSON -> IO () + |]) + +$(mangle + "void ctorHsJSONBool(HsJSON*, bool)" + [d| + foreign import ccall unsafe + c_constructHsJSONBool :: Ptr HsJSON -> CBool -> IO () + |]) + +$(mangle + "void ctorHsJSONInt(HsJSON*, int64_t)" + [d| + foreign import ccall unsafe + c_constructHsJSONInt :: Ptr HsJSON -> CLong -> IO () + |]) + +$(mangle + "void ctorHsJSONDouble(HsJSON*, double)" + [d| + foreign import ccall unsafe + c_constructHsJSONDouble :: Ptr HsJSON -> CDouble -> IO () + |]) + +$(mangle + "void ctorHsJSONString(HsJSON*, HsString*)" + [d| + foreign import ccall unsafe + c_constructHsJSONString :: Ptr HsJSON -> Ptr HsText -> IO () + |]) + +$(mangle + "void ctorHsJSONArray(HsJSON*, HsArray*)" + [d| + foreign import ccall unsafe + c_constructHsJSONArray :: Ptr HsJSON -> Ptr (HsArray HsJSON) -> IO () + |]) + +$(mangle + "void ctorHsJSONObject(HsJSON*, HsMap*)" + [d| + foreign import ccall unsafe + c_constructHsJSONObject :: Ptr HsJSON -> Ptr (HsObject HsJSON) -> IO () + |]) + +-- Derive Marshallables first +$(deriveMarshallableUnsafe "HsMaybeInt" [t| HsMaybe Int |]) +$(deriveMarshallableUnsafe "HsMaybeDouble" [t| HsMaybe Double |]) +$(deriveMarshallableUnsafe "HsMaybeString" [t| HsMaybe HsByteString |]) +$(deriveMarshallableUnsafe "HsMaybeString" [t| HsMaybe HsText |]) +$(deriveMarshallableUnsafe "HsMaybeString" [t| HsMaybe HsLenientText |]) + +$(deriveMarshallableUnsafe "HsEitherStringInt" [t| HsEither HsText Int |]) +$(deriveMarshallableUnsafe "HsEitherStringDouble" [t| HsEither HsText Double |]) +$(deriveMarshallableUnsafe "HsEitherStringString" [t| HsEither HsText HsByteString |]) +$(deriveMarshallableUnsafe "HsEitherStringString" [t| HsEither HsText HsText |]) +$(deriveMarshallableUnsafe "HsEitherStringInt" [t| HsEither HsLenientText Int |]) +$(deriveMarshallableUnsafe "HsEitherStringDouble" [t| HsEither HsLenientText Double |]) +$(deriveMarshallableUnsafe "HsEitherStringString" [t| HsEither HsLenientText HsByteString |]) +$(deriveMarshallableUnsafe "HsEitherStringString" [t| HsEither HsLenientText HsLenientText |]) + +$(deriveMarshallableUnsafe "HsEitherStringArrayInt" [t| HsEither HsText (HsList Int) |]) +$(deriveMarshallableUnsafe "HsEitherStringArrayDouble" [t| HsEither HsText (HsList Double) |]) +$(deriveMarshallableUnsafe "HsEitherStringArrayString" [t| HsEither HsText (HsList HsByteString) |]) +$(deriveMarshallableUnsafe "HsEitherStringArrayString" [t| HsEither HsText (HsList HsText) |]) +$(deriveMarshallableUnsafe "HsEitherStringArrayInt" [t| HsEither HsLenientText (HsList Int) |]) +$(deriveMarshallableUnsafe "HsEitherStringArrayDouble" [t| HsEither HsLenientText (HsList Double) |]) +$(deriveMarshallableUnsafe "HsEitherStringArrayString" [t| HsEither HsLenientText (HsList HsByteString) |]) +$(deriveMarshallableUnsafe "HsEitherStringArrayString" [t| HsEither HsLenientText (HsList HsLenientText) |]) + +instance Assignable (HsEither HsText Int) +instance Assignable (HsEither HsText Double) +instance Assignable (HsEither HsText HsByteString) +instance Assignable (HsEither HsText HsText) + +$(deriveMarshallableUnsafe "HsString" [t| HsString |]) +$(deriveMarshallableUnsafe "HsString" [t| HsByteString |]) +$(deriveMarshallableUnsafe "HsString" [t| HsLenientText |]) +$(deriveMarshallableUnsafe "HsString" [t| HsText |]) + +instance Assignable HsText +instance Assignable HsByteString +instance Assignable HsLenientText + +$(deriveMarshallableUnsafe "HsStringPiece" [t| HsStringPiece |]) + +$(deriveMarshallableUnsafe "HsOptionBool" [t| HsOption Bool |]) +$(deriveMarshallableUnsafe "HsOptionBool" [t| HsOption CBool |]) +$(deriveMarshallableUnsafe "HsOptionInt16" [t| HsOption CShort |]) +$(deriveMarshallableUnsafe "HsOptionInt16" [t| HsOption Int16 |]) +$(deriveMarshallableUnsafe "HsOptionInt32" [t| HsOption CInt |]) +$(deriveMarshallableUnsafe "HsOptionInt32" [t| HsOption Int32 |]) +$(deriveMarshallableUnsafe "HsOptionInt64" [t| HsOption CLong |]) +$(deriveMarshallableUnsafe "HsOptionInt64" [t| HsOption Int64 |]) +$(deriveMarshallableUnsafe "HsOptionUInt8" [t| HsOption CSChar |]) +$(deriveMarshallableUnsafe "HsOptionUInt8" [t| HsOption Word8 |]) +$(deriveMarshallableUnsafe "HsOptionUInt32" [t| HsOption CUInt |]) +$(deriveMarshallableUnsafe "HsOptionUInt32" [t| HsOption Word32 |]) +$(deriveMarshallableUnsafe "HsOptionUInt64" [t| HsOption CULong |]) +$(deriveMarshallableUnsafe "HsOptionUInt64" [t| HsOption Word64 |]) +$(deriveMarshallableUnsafe "HsOptionFloat" [t| HsOption Float |]) +$(deriveMarshallableUnsafe "HsOptionFloat" [t| HsOption CFloat |]) +$(deriveMarshallableUnsafe "HsOptionDouble" [t| HsOption Double |]) +$(deriveMarshallableUnsafe "HsOptionDouble" [t| HsOption CDouble |]) +$(deriveMarshallableUnsafe "HsOptionString" [t| HsOption HsText |]) +$(deriveMarshallableUnsafe "HsOptionString" [t| HsOption HsLenientText |]) +$(deriveMarshallableUnsafe "HsOptionString" [t| HsOption HsByteString |]) +$(deriveMarshallableUnsafe "HsOptionStringView" [t| HsOption HsStringPiece |]) +$(deriveMarshallableUnsafe "HsOptionHsJSON" [t| HsOption HsJSON |]) + +$(deriveMarshallableUnsafe "HsArrayInt16" [t| HsList CShort |]) +$(deriveMarshallableUnsafe "HsArrayInt16" [t| HsList Int16 |]) +$(deriveMarshallableUnsafe "HsArrayInt32" [t| HsList CInt |]) +$(deriveMarshallableUnsafe "HsArrayInt32" [t| HsList Int32 |]) +$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsList Int |]) +$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsList Int64 |]) +$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsList CLong |]) +$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsList CBool |]) +$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsList Word8 |]) +$(deriveMarshallableUnsafe "HsArrayUInt32" [t| HsList CUInt |]) +$(deriveMarshallableUnsafe "HsArrayUInt32" [t| HsList Word32 |]) +$(deriveMarshallableUnsafe "HsArrayUInt64" [t| HsList CULong |]) +$(deriveMarshallableUnsafe "HsArrayUInt64" [t| HsList Word64 |]) +$(deriveMarshallableUnsafe "HsArrayFloat" [t| HsList Float |]) +$(deriveMarshallableUnsafe "HsArrayFloat" [t| HsList CFloat |]) +$(deriveMarshallableUnsafe "HsArrayDouble" [t| HsList Double |]) +$(deriveMarshallableUnsafe "HsArrayDouble" [t| HsList CDouble |]) +$(deriveMarshallableUnsafe "HsArrayString" [t| HsList HsByteString |]) +$(deriveMarshallableUnsafe "HsArrayString" [t| HsList HsText |]) +$(deriveMarshallableUnsafe "HsArrayString" [t| HsList HsLenientText |]) +$(deriveMarshallableUnsafe "HsArrayStringPiece" [t| HsList HsStringPiece |]) +$(deriveMarshallableUnsafe "HsArrayJSON" [t| HsList HsJSON |]) +$(deriveMarshallableUnsafe "HsArrayInt16" [t| HsArray CShort |]) +$(deriveMarshallableUnsafe "HsArrayInt16" [t| HsArray Int16 |]) +$(deriveMarshallableUnsafe "HsArrayInt32" [t| HsArray CInt |]) +$(deriveMarshallableUnsafe "HsArrayInt32" [t| HsArray Int32 |]) +$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsArray Int |]) +$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsArray Int64 |]) +$(deriveMarshallableUnsafe "HsArrayInt64" [t| HsArray CLong |]) +$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsArray CBool |]) +$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsArray Word8 |]) +$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsArray CSChar |]) +$(deriveMarshallableUnsafe "HsArrayUInt8" [t| HsArray CUChar |]) +$(deriveMarshallableUnsafe "HsArrayUInt16" [t| HsArray CUShort |]) +$(deriveMarshallableUnsafe "HsArrayUInt32" [t| HsArray CUInt |]) +$(deriveMarshallableUnsafe "HsArrayUInt32" [t| HsArray Word32 |]) +$(deriveMarshallableUnsafe "HsArrayUInt64" [t| HsArray CULong |]) +$(deriveMarshallableUnsafe "HsArrayUInt64" [t| HsArray Word64 |]) +$(deriveMarshallableUnsafe "HsArrayFloat" [t| HsArray Float |]) +$(deriveMarshallableUnsafe "HsArrayFloat" [t| HsArray CFloat |]) +$(deriveMarshallableUnsafe "HsArrayDouble" [t| HsArray Double |]) +$(deriveMarshallableUnsafe "HsArrayDouble" [t| HsArray CDouble |]) +$(deriveMarshallableUnsafe "HsArrayString" [t| HsArray HsByteString |]) +$(deriveMarshallableUnsafe "HsArrayString" [t| HsArray HsText |]) +$(deriveMarshallableUnsafe "HsArrayString" [t| HsArray HsLenientText |]) +$(deriveMarshallableUnsafe "HsArrayStringPiece" [t| HsArray HsStringPiece |]) +$(deriveMarshallableUnsafe "HsArrayJSON" [t| HsArray HsJSON |]) + +$(deriveMarshallableUnsafe "HsSetUInt8" [t| HsHashSet CUChar |]) +$(deriveMarshallableUnsafe "HsSetUInt16" [t| HsHashSet CUShort |]) +$(deriveMarshallableUnsafe "HsSetInt32" [t| HsHashSet CInt |]) +$(deriveMarshallableUnsafe "HsSetInt32" [t| HsHashSet Int32 |]) +$(deriveMarshallableUnsafe "HsSetInt64" [t| HsHashSet Int |]) +$(deriveMarshallableUnsafe "HsSetInt64" [t| HsHashSet Int64 |]) +$(deriveMarshallableUnsafe "HsSetInt64" [t| HsHashSet CLong |]) +$(deriveMarshallableUnsafe "HsSetUInt8" [t| HsHashSet CBool |]) +$(deriveMarshallableUnsafe "HsSetUInt8" [t| HsHashSet Word8 |]) +$(deriveMarshallableUnsafe "HsSetUInt8" [t| HsHashSet CSChar |]) +$(deriveMarshallableUnsafe "HsSetUInt32" [t| HsHashSet CUInt |]) +$(deriveMarshallableUnsafe "HsSetUInt32" [t| HsHashSet Word32 |]) +$(deriveMarshallableUnsafe "HsSetUInt64" [t| HsHashSet CULong |]) +$(deriveMarshallableUnsafe "HsSetUInt64" [t| HsHashSet Word64 |]) +$(deriveMarshallableUnsafe "HsSetFloat" [t| HsHashSet Float |]) +$(deriveMarshallableUnsafe "HsSetDouble" [t| HsHashSet Double |]) +$(deriveMarshallableUnsafe "HsSetString" [t| HsHashSet HsByteString |]) +$(deriveMarshallableUnsafe "HsSetString" [t| HsHashSet HsText |]) +$(deriveMarshallableUnsafe "HsSetString" [t| HsHashSet HsLenientText |]) +$(deriveMarshallableUnsafe "HsSetJSON" [t| HsHashSet HsJSON |]) + +$(deriveMarshallableUnsafe "HsMapIntInt" [t| HsIntMap Int |]) +$(deriveMarshallableUnsafe "HsMapUInt8UInt8" [t| HsHashMap CUChar CUChar |]) +$(deriveMarshallableUnsafe "HsMapUInt16UInt16" [t| HsHashMap CUShort CUShort |]) +$(deriveMarshallableUnsafe "HsMapIntDouble" [t| HsIntMap Double |]) +$(deriveMarshallableUnsafe "HsMapIntString" [t| HsIntMap HsByteString |]) +$(deriveMarshallableUnsafe "HsMapIntString" [t| HsIntMap HsText |]) +$(deriveMarshallableUnsafe "HsMapIntString" [t| HsIntMap HsLenientText |]) +$(deriveMarshallableUnsafe "HsMapStringInt" [t| HsObject Int |]) +$(deriveMarshallableUnsafe "HsMapStringDouble" [t| HsObject Double |]) +$(deriveMarshallableUnsafe "HsMapStringString" [t| HsObject HsByteString |]) +$(deriveMarshallableUnsafe "HsMapStringString" [t| HsObject HsText |]) +$(deriveMarshallableUnsafe "HsMapStringString" [t| HsObject HsLenientText |]) + +$(deriveMarshallableUnsafe "HsMapIntInt" [t| HsHashMap Int Int |]) +$(deriveMarshallableUnsafe "HsMapInt32Int32" [t| HsHashMap Int32 Int32 |]) +$(deriveMarshallableUnsafe "HsMapInt32Double" [t| HsHashMap Int32 Double |]) +$(deriveMarshallableUnsafe "HsMapInt32String" [t| HsHashMap Int32 HsText |]) +$(deriveMarshallableUnsafe "HsMapInt32String" [t| HsHashMap Int32 HsLenientText |]) +$(deriveMarshallableUnsafe "HsMapInt32String" [t| HsHashMap Int32 HsByteString |]) +$(deriveMarshallableUnsafe "HsMapDoubleInt32" [t| HsHashMap Double Int32 |]) +$(deriveMarshallableUnsafe "HsMapStringInt32" [t| HsHashMap HsByteString Int32 |]) +$(deriveMarshallableUnsafe "HsMapStringInt32" [t| HsHashMap HsText Int32 |]) +$(deriveMarshallableUnsafe "HsMapStringInt32" [t| HsHashMap HsLenientText Int32 |]) +$(deriveMarshallableUnsafe "HsMapStringDouble" [t| HsHashMap HsByteString Double |]) +$(deriveMarshallableUnsafe "HsMapStringDouble" [t| HsHashMap HsText Double |]) +$(deriveMarshallableUnsafe "HsMapStringDouble" [t| HsHashMap HsLenientText Double |]) +$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsText HsText |]) +$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsText HsByteString |]) +$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsLenientText HsLenientText |]) +$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsLenientText HsByteString |]) +$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsByteString HsText |]) +$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsByteString HsLenientText |]) +$(deriveMarshallableUnsafe "HsMapStringString" [t| HsHashMap HsByteString HsByteString |]) + +$(deriveMarshallableUnsafe "HsObjectJSON" [t| HsObject HsJSON |]) +$(deriveMarshallableUnsafe "HsJSON" [t| HsJSON |]) + +-- These are mutually recurisve, we have to splice them together +$(do + a <- deriveHsArrayUnsafe "HsJSON" [t| HsJSON |] + b <- deriveHsArrayUnsafe "String" [t| HsText |] + c <- [d| + instance Constructible HsJSON where + newValue (HsJSON _val) = error $ "HsStruct.HsJSON cannot be built on heap" + constructValue ptr (HsJSON val) = + case val of + Null -> c_constructHsJSONNull ptr + Bool b -> c_constructHsJSONBool ptr (fromBool b) + Number n -> case (floatingOrInteger n :: Either CDouble CLong) of + Left r -> c_constructHsJSONDouble ptr r + Right _ -> case toBoundedInteger n of + Just i -> c_constructHsJSONInt ptr i + Nothing -> c_constructHsJSONDouble ptr $ toRealFloat n + String txt -> withCxxObject (HsText txt) $ c_constructHsJSONString ptr + Array v -> withCxxObject (HsArray (Vector.map HsJSON v)) $ + c_constructHsJSONArray ptr + Object o -> withCxxObject (HsObject (HsJSON <$> o)) $ + c_constructHsJSONObject ptr + + instance Constructible (HsObject HsJSON) where + newValue (HsObject _o) = error "HsObject HsJSON cannot be made on heap" + constructValue ptr (HsObject m) = + withCxxObject (HsArray (Vector.fromList (map (HsText . keyToText) keys))) $ \keys_p -> + withCxxObject (HsArray (Vector.fromList vals)) $ \vals_p -> + c_constructHsObjectJSON ptr keys_p vals_p + where + (keys, vals) = unzip $ objectToList m + |] + return $ a ++ b ++ c + ) + +-- Derive constructions after marshallable +$(#{derive_hs_option_unsafe Bool} [t| Bool |]) +$(#{derive_hs_option_unsafe Bool} [t| CBool |]) +$(#{derive_hs_option_unsafe Int16} [t| CShort |]) +$(#{derive_hs_option_unsafe Int16} [t| Int16 |]) +$(#{derive_hs_option_unsafe Int32} [t| CInt |]) +$(#{derive_hs_option_unsafe Int32} [t| Int32 |]) +$(#{derive_hs_option_unsafe Int64} [t| CLong |]) +$(#{derive_hs_option_unsafe Int64} [t| Int64 |]) +$(#{derive_hs_option_unsafe UInt8} [t| CSChar |]) +$(#{derive_hs_option_unsafe UInt8} [t| Word8 |]) +$(#{derive_hs_option_unsafe UInt32} [t| CUInt |]) +$(#{derive_hs_option_unsafe UInt32} [t| Word32 |]) +$(#{derive_hs_option_unsafe UInt64} [t| CULong |]) +$(#{derive_hs_option_unsafe UInt64} [t| Word64 |]) +$(#{derive_hs_option_unsafe Float} [t| Float |]) +$(#{derive_hs_option_unsafe Float} [t| CFloat |]) +$(#{derive_hs_option_unsafe Double} [t| Double |]) +$(#{derive_hs_option_unsafe Double} [t| CDouble |]) +$(#{derive_hs_option_unsafe String} [t| HsText |]) +$(#{derive_hs_option_unsafe String} [t| HsLenientText |]) +$(#{derive_hs_option_unsafe String} [t| HsByteString |]) +$(#{derive_hs_option_unsafe StringView} [t| HsStringPiece |]) +$(#{derive_hs_option_unsafe HsJSON} [t| HsJSON |]) + +$(deriveHsArrayUnsafe "Int16" [t| CShort |]) +$(deriveHsArrayUnsafe "Int16" [t| Int16 |]) +$(deriveHsArrayUnsafe "Int32" [t| CInt |]) +$(deriveHsArrayUnsafe "Int32" [t| Int32 |]) +$(deriveHsArrayUnsafe "Int64" [t| CLong |]) +$(deriveHsArrayUnsafe "Int64" [t| Int64 |]) +$(deriveHsArrayUnsafe "UInt8" [t| CBool |]) +$(deriveHsArrayUnsafe "UInt8" [t| Word8 |]) +$(deriveHsArrayUnsafe "UInt8" [t| CUChar |]) +$(deriveHsArrayUnsafe "UInt8" [t| CSChar |]) +$(deriveHsArrayUnsafe "UInt16" [t| CUShort |]) +$(deriveHsArrayUnsafe "UInt32" [t| CUInt |]) +$(deriveHsArrayUnsafe "UInt32" [t| Word32 |]) +$(deriveHsArrayUnsafe "UInt64" [t| CULong |]) +$(deriveHsArrayUnsafe "UInt64" [t| Word64 |]) +$(deriveHsArrayUnsafe "Float" [t| Float |]) +$(deriveHsArrayUnsafe "Float" [t| CFloat |]) +$(deriveHsArrayUnsafe "Double" [t| Double |]) +$(deriveHsArrayUnsafe "Double" [t| CDouble |]) +$(deriveHsArrayUnsafe "String" [t| HsLenientText |]) +$(deriveHsArrayUnsafe "String" [t| HsByteString |]) +$(deriveHsArrayUnsafe "StringView" [t| HsStringPiece |]) + +$(deriveHsHashSetUnsafe "Int16" [t| CShort |]) +$(deriveHsHashSetUnsafe "Int16" [t| Int16 |]) +$(deriveHsHashSetUnsafe "Int32" [t| CInt |]) +$(deriveHsHashSetUnsafe "Int32" [t| Int32 |]) +$(deriveHsHashSetUnsafe "Int64" [t| Int |]) +$(deriveHsHashSetUnsafe "Int64" [t| Int64 |]) +$(deriveHsHashSetUnsafe "Int64" [t| CLong |]) +$(deriveHsHashSetUnsafe "UInt8" [t| CBool |]) +$(deriveHsHashSetUnsafe "UInt8" [t| Word8 |]) +$(deriveHsHashSetUnsafe "UInt8" [t| CSChar |]) +$(deriveHsHashSetUnsafe "UInt8" [t| CUChar |]) +$(deriveHsHashSetUnsafe "UInt16" [t| CUShort |]) +$(deriveHsHashSetUnsafe "UInt32" [t| CUInt |]) +$(deriveHsHashSetUnsafe "UInt32" [t| Word32 |]) +$(deriveHsHashSetUnsafe "UInt64" [t| CULong |]) +$(deriveHsHashSetUnsafe "UInt64" [t| Word64 |]) +$(deriveHsHashSetUnsafe "Float" [t| Float |]) +$(deriveHsHashSetUnsafe "Double" [t| Double |]) +$(deriveHsHashSetUnsafe "String" [t| HsByteString |]) +$(deriveHsHashSetUnsafe "String" [t| HsText |]) +$(deriveHsHashSetUnsafe "String" [t| HsLenientText |]) +$(deriveHsHashSetUnsafe "HsJSON" [t| HsJSON |]) + +-- O(n^2) derivations, try to derive just what you need +$(deriveHsHashMapUnsafe "IntInt" [t| Int |] [t| Int |]) +$(deriveHsHashMapUnsafe "UInt8UInt8" [t| CUChar |] [t| CUChar |]) +$(deriveHsHashMapUnsafe "UInt16UInt16" [t| CUShort |] [t| CUShort |]) +$(deriveHsHashMapUnsafe "Int32Int32" [t| Int32 |] [t| Int32 |]) +$(deriveHsHashMapUnsafe "Int32Double" [t| Int32 |] [t| Double |]) +$(deriveHsHashMapUnsafe "Int32String" [t| Int32 |] [t| HsByteString |]) +$(deriveHsHashMapUnsafe "Int32String" [t| Int32 |] [t| HsText |]) +$(deriveHsHashMapUnsafe "Int32String" [t| Int32 |] [t| HsLenientText |]) +$(deriveHsHashMapUnsafe "DoubleInt32" [t| Double |] [t| Int32 |]) +$(deriveHsHashMapUnsafe "StringInt32" [t| HsByteString |] [t| Int32 |]) +$(deriveHsHashMapUnsafe "StringInt32" [t| HsText |] [t| Int32 |]) +$(deriveHsHashMapUnsafe "StringInt32" [t| HsLenientText |] [t| Int32 |]) +$(deriveHsHashMapUnsafe "StringDouble" [t| HsText |] [t| Double |]) +$(deriveHsHashMapUnsafe "StringDouble" [t| HsLenientText |] [t| Double |]) +$(deriveHsHashMapUnsafe "StringDouble" [t| HsByteString |] [t| Double |]) +$(deriveHsHashMapUnsafe "StringString" [t| HsText |] [t| HsText |]) +$(deriveHsHashMapUnsafe "StringString" [t| HsText |] [t| HsByteString |]) +$(deriveHsHashMapUnsafe "StringString" [t| HsLenientText |] [t| HsLenientText |]) +$(deriveHsHashMapUnsafe "StringString" [t| HsLenientText |] [t| HsByteString |]) +$(deriveHsHashMapUnsafe "StringString" [t| HsByteString |] [t| HsText |]) +$(deriveHsHashMapUnsafe "StringString" [t| HsByteString |] [t| HsLenientText |]) +$(deriveHsHashMapUnsafe "StringString" [t| HsByteString |] [t| HsByteString |]) diff --git a/Foreign/CPP/HsStruct/Unsafe.hsc b/Foreign/CPP/HsStruct/Unsafe.hsc new file mode 100644 --- /dev/null +++ b/Foreign/CPP/HsStruct/Unsafe.hsc @@ -0,0 +1,56 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Foreign.CPP.HsStruct.Unsafe + ( unsafeMaybeRelease + , unsafeMaybeSteal + , unsafeMaybePeek + , unsafeToHsStringPiece + ) where + +import Control.Exception +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Foreign + +import Foreign.CPP.Marshallable +import Foreign.CPP.HsStruct.Types + +#include + +-- | Returns the raw pointer to the optional foreign object in the 'HsMaybe'. +-- The 'HsMaybe' releases the ownership and becomes owning nothing. +-- Think is as calling @std::unique_ptr::release()@. +-- +-- Haskell takes the responsibility of handling exceptions including +-- asynchronous exceptions and ensure the foreign object is disposed of +-- properly. Do /not/ use this function unless you intend to take over the +-- ownership /and/ extend the lifetime of the foreign object. Otherwise, +-- simply leave the ownership to C++ and keep the 'HsMaybe' intact. +-- +-- Use 'unsafeMaybeSteal' whenever the foreign object can be disposed of by +-- calling 'delete' from 'Destructible'. +unsafeMaybeRelease :: Ptr (HsMaybe a) -> IO (Ptr a) +unsafeMaybeRelease p = do + ptr <- #{peek DummyHsMaybe, ptr} p + #{poke DummyHsMaybe, ptr} p nullPtr + return ptr + +unsafeMaybePeek :: Ptr (HsMaybe a) -> IO (Ptr a) +unsafeMaybePeek p = #{peek DummyHsMaybe, ptr} p + +-- | Steals the raw pointer to the optional foreign object in 'HsMaybe'. +-- Haskell takes over the ownership and takes the responsibility of disposing +-- of it by calling 'delete'. The 'HsMaybe' releases the ownership and becomes +-- owning nothing. Think it as calling +-- @std::shared_ptr::shared_ptr(std::unique_ptr&&)@. +unsafeMaybeSteal :: Destructible a => Ptr (HsMaybe a) -> IO (ForeignPtr a) +unsafeMaybeSteal p = mask_ $ toSharedPtr =<< unsafeMaybeRelease p + +unsafeToHsStringPiece :: ByteString -> IO HsStringPiece +unsafeToHsStringPiece s = unsafeUseAsCStringLen s $ return . uncurry HsRange diff --git a/Foreign/CPP/HsStruct/Utils.hs b/Foreign/CPP/HsStruct/Utils.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/HsStruct/Utils.hs @@ -0,0 +1,43 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Foreign.CPP.HsStruct.Utils + ( withCxxObject + , withDefaultCxxObject + ) where + + +import Control.Exception (bracket) +import Foreign (Ptr) +import Foreign.CPP.Addressable +import Foreign.CPP.Marshallable + +import Util.Memory + +-- | allocates space for an object, calls `constructValue` with a value +-- and `destruct`s the object when done. +withCxxObject + :: (Constructible a, Destructible a, Addressable a) + => a + -> (Ptr a -> IO b) + -> IO b +withCxxObject val func = + allocaBytesAligned (sizeOf val) (alignment val) $ \s -> + bracket (constructValue s val >> return s) destruct func + +-- | allocates space for an object, calls `constructDefault` +-- and `destruct`s the object when done. +withDefaultCxxObject + :: forall a b . (DefaultConstructible a, Destructible a, Addressable a) + => (Ptr a -> IO b) + -> IO b +withDefaultCxxObject func = + allocaBytesAligned (sizeOf val) (alignment val) $ \s -> + bracket (constructDefault s >> return s) destruct func + where + val = undefined :: a diff --git a/Foreign/CPP/Marshallable.hs b/Foreign/CPP/Marshallable.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/Marshallable.hs @@ -0,0 +1,181 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE DefaultSignatures #-} +module Foreign.CPP.Marshallable + ( makeShared + , toSharedPtr + , destructAndFree + , DefaultConstructible(..) + , Constructible(..) + , Destructible(..) + , Assignable(..) + ) where + +-- Importing types for default instantiations of Constructible +import Data.Ratio (Ratio) +import Foreign.C.Types +import GHC.Fingerprint (Fingerprint) +import System.Posix.Types + +import Foreign.Storable +import Foreign.Marshal.Utils +import Control.Exception (mask_) +import Foreign hiding (alloca, allocaBytes, allocaArray) + + +-- Utility functions ---------------------------------------------------------- + +-- | Returns a 'ForeignPtr' that owns and manages a foreign object through +-- a pointer and disposes of that object when the lifetime of the 'ForeignPtr' +-- ends. +-- It is similar to @std::make_shared@ in C++. +-- The object pointed to is both allocated+ctor'd and +-- destructed+deallocated in C++ +makeShared :: (DefaultConstructible a, Destructible a) => IO (ForeignPtr a) +makeShared = newDefault >>= toSharedPtr + +-- | Returns a 'ForeignPtr' that owns and manages a foreign object through +-- a pointer and disposes of that object when the lifetime of the 'ForeignPtr' +-- ends. +toSharedPtr :: Destructible a => Ptr a -> IO (ForeignPtr a) +toSharedPtr = newForeignPtr deleteFunPtr + +-- | Simply calls 'destruct' and 'free'. This should be used instead of +-- 'delete' when the memory is allocated by 'malloc' or 'mallocBytes' in +-- Haskell and the object is constructed by __placement new__ in C++, or +-- 'construct' / 'constructDefault' in Haskell. +destructAndFree :: Destructible a => Ptr a -> IO () +destructAndFree p = destruct p >> free p + +-- Typeclasses ---------------------------------------------------------------- + +-- | Typeclass to call into C++ allocators and constructors for objects. +class DefaultConstructible a where + -- | Allocate the space and invoke the constructor in C++. + -- + -- This is equivalent to __new expression__ in C++, and assumes that + -- the object has an empty constructor defined in its class definition. + newDefault :: IO (Ptr a) + + -- | Invoke the construct of the object in C++. It does no checks on + -- whether the ptr points to an already constructed object. + -- + -- This is often used with 'Foreign.Marshal.Alloc.alloca' in Haskell, + -- to do __placement new__ in C++. + constructDefault :: Ptr a -> IO () + + +-- | Similar to @DefaultConstructible@ but also initializes the value for +-- the foreign object +-- Default implementations of storable types allow using common types like +-- Int, Char etc inside other complex types like HsEither. +-- You *must* not use these default implementations when defining instances for +-- complex C++ types. Doing so may lead to memory leaks. +class Constructible a where + newValue :: a -> IO (Ptr a) + default newValue :: Storable a => a -> IO (Ptr a) + newValue = new + + constructValue :: Ptr a -> a -> IO () + default constructValue :: Storable a => Ptr a -> a -> IO () + constructValue = poke + +instance Constructible Bool +instance Constructible Char +instance Constructible Double +instance Constructible Float +instance Constructible Int +instance Constructible Int8 +instance Constructible Int16 +instance Constructible Int32 +instance Constructible Int64 +instance Constructible Word +instance Constructible Word8 +instance Constructible Word16 +instance Constructible Word32 +instance Constructible Word64 +instance Constructible () +instance Constructible Fingerprint +instance Constructible CUIntMax +instance Constructible CIntMax +instance Constructible CUIntPtr +instance Constructible CIntPtr +instance Constructible CSUSeconds +instance Constructible CUSeconds +instance Constructible CTime +instance Constructible CClock +instance Constructible CSigAtomic +instance Constructible CWchar +instance Constructible CSize +instance Constructible CPtrdiff +instance Constructible CDouble +instance Constructible CFloat +instance Constructible CULLong +instance Constructible CLLong +instance Constructible CULong +instance Constructible CLong +instance Constructible CUInt +instance Constructible CInt +instance Constructible CUShort +instance Constructible CShort +instance Constructible CUChar +instance Constructible CSChar +instance Constructible CChar +instance Constructible CBool +instance Constructible IntPtr +instance Constructible WordPtr +instance Constructible Fd +instance Constructible CRLim +instance Constructible CTcflag +instance Constructible CSpeed +instance Constructible CCc +instance Constructible CUid +instance Constructible CNlink +instance Constructible CGid +instance Constructible CSsize +instance Constructible CPid +instance Constructible COff +instance Constructible CMode +instance Constructible CIno +instance Constructible CDev +instance (Storable a, Integral a) => Constructible (Ratio a) + + +-- | Typeclass to call into C++ destructors and deallocators for objects. +class Destructible a where + -- | Invoke the destructor to free the resources owned by the object, + -- the storage of the object itself is untouched, the object must not be + -- used after this. + -- + -- This is often used with 'Foreign.Marshal.Alloc.alloca' in Haskell + -- and __placement new__ in C++. + destruct :: Ptr a -> IO () + + -- | Invoke the destructor and also deallocate the storage of the object. + -- The object must not be used after this. + -- + -- This is equivalent to __delete expression__ in C++, so the object + -- must be a non-array object created by a __new expression__ in C++. + delete :: Ptr a -> IO () + + -- | Returns the pointer to the foreign delete function, i.e. the one + -- called by @delete@ above. + -- This is often used as the 'FinalizerPtr' of 'ForeignPtr'. + deleteFunPtr :: FunPtr (Ptr a -> IO ()) + + +-- | Typeclass to read/write values to foreign objects. Implements the +-- functionality provided by @Storable@ typeclass, but for complex C++ objects. +-- The class instance must ensure that values being "poked" are correctly +-- destructed before assignment. +class Assignable a where + -- | Write a value to given memory location. Similar to @Storable.poke@ + assign :: Ptr a -> a -> IO () + default assign :: (Constructible a, Destructible a) => Ptr a -> a -> IO () + assign p val = mask_ $ destruct p >> constructValue p val diff --git a/Foreign/CPP/Marshallable/TH.hs b/Foreign/CPP/Marshallable/TH.hs new file mode 100644 --- /dev/null +++ b/Foreign/CPP/Marshallable/TH.hs @@ -0,0 +1,135 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{- | +This module provides facilities to auto generate instances for +@DefaultConstructible@ and @Destructible@ typeclasses. It depends +on certain functions being exposed via C++, which can also be generated +by using C++ macros defined in 'Marshallable.h'. +-} +{-# LANGUAGE TemplateHaskell #-} +module Foreign.CPP.Marshallable.TH + ( module Marshallable + -- Generate both DefaultConstructible and Destructible instances + , deriveMarshallableUnsafe + , deriveMarshallableSafe + -- Generate Destructible instance + , deriveDestructibleSafe + , deriveDestructibleUnsafe + -- Generate DefaultConstructible instance + , deriveDefConstructibleUnsafe + , deriveDefConstructibleSafe + ) where + +import Control.Monad (liftM2) +import Data.Char +import Foreign.Ptr +import Language.Haskell.TH + +import Foreign.CPP.Marshallable as Marshallable + +-- | This is a Template Haskell function which is used in conjunction with +-- @HS_DEFINE_DESTRUCTIBLE@ from "Destructible.h" to generate instances for +-- 'Destructible'. Use 'deriveDestructibleSafe' instead if the destructor +-- can block. +deriveDestructibleUnsafe :: String -> TypeQ -> Q [Dec] +deriveDestructibleUnsafe = derive destructSpec unsafe + +-- | This is the safe version of 'deriveDestructibleUnsafe'. Use this instead +-- if the destructor can block. +deriveDestructibleSafe :: String -> TypeQ -> Q [Dec] +deriveDestructibleSafe = derive destructSpec safe + +-- | This is a Template Haskell function which is used in conjunction with +-- @HS_DEFINE_DEFAULT_CONSTRUCTIBLE@ from "Construcible.h" to generate +-- instances for 'DefaultConstrucible'. Use 'deriveDefConstructibleSafe' +-- instead if the constructor can block. +deriveDefConstructibleUnsafe :: String -> TypeQ -> Q [Dec] +deriveDefConstructibleUnsafe = derive constructSpec unsafe + +-- | This is the safe version of 'deriveDefConstructibleUnsafe'. Use this +-- instead if the constructor can block. +deriveDefConstructibleSafe :: String -> TypeQ -> Q [Dec] +deriveDefConstructibleSafe = derive constructSpec safe + +-- | Function to generate both @DefaultConstructible@ and @Destructible@ +-- instances. +deriveMarshallableUnsafe :: String -> TypeQ -> Q [Dec] +deriveMarshallableUnsafe cppName hsType = liftM2 (++) + (deriveDefConstructibleUnsafe cppName hsType) + (deriveDestructibleUnsafe cppName hsType) + +-- | Safe version of @deriveMarshallableUnsafe@. +deriveMarshallableSafe :: String -> TypeQ -> Q [Dec] +deriveMarshallableSafe cppName hsType = liftM2 (++) + (deriveDefConstructibleSafe cppName hsType) + (deriveDestructibleSafe cppName hsType) + +-- Specializations for different typeclasses ---------------------------------- + +data TypeClassSpec = TypeClassSpec + { tySpec_classNm :: TypeQ + , tySpec_functions :: [HsMethod] + } + +data HsMethod = HsMethod + { hs_name :: String + , hs_cppPrefix :: String + , hs_typeFn :: TypeQ -> TypeQ + } + +destructSpec :: TypeClassSpec +destructSpec = TypeClassSpec + { tySpec_classNm = [t| Destructible |] + , tySpec_functions = + [ HsMethod "destruct" "destructible_destruct" + (\hsType -> [t| Ptr $hsType -> IO () |]) + , HsMethod "delete" "destructible_delete" + (\hsType -> [t| Ptr $hsType -> IO () |]) + , HsMethod "deleteFunPtr" "&destructible_delete" + (\hsType -> [t| FunPtr (Ptr $hsType -> IO ()) |]) + ] + } + +constructSpec :: TypeClassSpec +constructSpec = TypeClassSpec + { tySpec_classNm = [t| DefaultConstructible |] + , tySpec_functions = + [ HsMethod "constructDefault" "constructible_constructDefault" + (\hsType -> [t| Ptr $hsType -> IO () |]) + , HsMethod "newDefault" "constructible_newDefault" + (\hsType -> [t| IO (Ptr $hsType) |]) + ] + } + +-- Common code ---------------------------------------------------------------- + +derive :: TypeClassSpec -> Safety -> String -> TypeQ -> Q [Dec] +derive TypeClassSpec{..} safety cppName hsType = do + (funs, forImps) <- unzip <$> mapM gen tySpec_functions + -- instance Destructible HsString where + instD <- instanceD + (cxt []) + [t| $tySpec_classNm $hsType |] + (map pure funs) + return $ instD: forImps + where + gen :: HsMethod -> Q (Dec, Dec) + gen HsMethod{..} = do + hsTypeStr <- map (\i -> if isAlphaNum i then i else '_') . pprint <$> hsType + let cppBinding = hs_cppPrefix ++ cppName + hsBinding = mkName $ hs_name ++ hsTypeStr ++ show safety + -- destruct = destructHsStructUnsafe + fun <- funD (mkName hs_name) + [ clause [] (normalB $ varE hsBinding) [] + ] + -- foreign import ccall unsafe "destructible_destructCppStruct" + -- destructHsStructUnsafe :: Ptr Hs -> IO () + forImp <- forImpD cCall safety cppBinding hsBinding $ + hs_typeFn hsType + return (fun, forImp) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +BSD License + +For hsthrift software + +Copyright (c) Facebook, Inc. and its affiliates. 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. + + * Neither the name Facebook nor the names of its contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 HOLDER OR CONTRIBUTORS 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/Util/ASan.hs b/Util/ASan.hs new file mode 100644 --- /dev/null +++ b/Util/ASan.hs @@ -0,0 +1,106 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.ASan + ( alloca + , allocaBytes + , allocaArray + , allocaArray0 + , allocaBytesAligned + , with + , byteStringWithCString + , byteStringWithCStringLen + , textWithCStringLen + , textWithCString + , textUseAsPtr + ) where + +import Control.Exception + +import Foreign hiding + (alloca, allocaBytes, allocaBytesAligned, allocaArray, allocaArray0, with) +import Foreign.C + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BI + +import Data.Text.Internal (Text(..)) +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Foreign as TF + +import Util.FFI + +-- The following functions already support ASan (they already allocate using +-- malloc): +-- newCStringFromText + +alloca :: Storable a => (Ptr a -> IO b) -> IO b +alloca = doAlloca undefined + where + doAlloca :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b' + doAlloca dummy = allocaBytesAligned (sizeOf dummy) (alignment dummy) + +allocaBytes :: Int -> (Ptr a -> IO b) -> IO b +allocaBytes size = bracket (mallocBytes size) free + +-- alignedAlloc calls an aligned allocation function that is platform-dependent +-- void *alignedAlloc( size_t alignment, size_t size ); +foreign import ccall unsafe "alignedAlloc" + cAlignedAlloc :: CSize -> CSize -> IO (Ptr a) + +allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b +allocaBytesAligned size alignment = + bracket (cAlignedAlloc (fromIntegral alignment) (fromIntegral size)) free + +allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b +allocaArray = doAlloca undefined + where + doAlloca :: Storable a' => a' -> Int -> (Ptr a' -> IO b') -> IO b' + doAlloca dummy size = allocaBytesAligned (size * sizeOf dummy) + (alignment dummy) + +allocaArray0 :: Storable a => Int -> (Ptr a -> IO b) -> IO b +allocaArray0 size = allocaArray (size + 1) + +with :: Storable a => a -> (Ptr a -> IO b) -> IO b +with val f = + alloca $ \ptr -> do + poke ptr val + f ptr + +-- Text / ByteString marshalling + +textWithCString :: Text -> (CString -> IO a) -> IO a +textWithCString = byteStringWithCString . encodeUtf8 + +byteStringWithCString :: BS.ByteString -> (CString -> IO a) -> IO a +byteStringWithCString (BI.PS fp off len) fun = + allocaBytes (len+1) $ \ptr' -> do + unsafeWithForeignPtr fp $ \ptr -> do + copyBytes ptr' (ptr `plusPtr` off) len + poke (ptr' `plusPtr` len) (0 :: Word8) + fun ptr' + + +textWithCStringLen :: Text -> (CStringLen -> IO a) -> IO a +textWithCStringLen = byteStringWithCStringLen . encodeUtf8 + +byteStringWithCStringLen :: BS.ByteString -> (CStringLen -> IO a) -> IO a +byteStringWithCStringLen (BI.PS _ _ 0) fun = fun (nullPtr, 0) +byteStringWithCStringLen (BI.PS fp off len) fun = + allocaBytes len $ \ptr' -> do + unsafeWithForeignPtr fp $ \ptr -> copyBytes ptr' (ptr `plusPtr` off) len + fun (ptr', len) + +-- Text marshalling + +textUseAsPtr :: Text -> (Ptr Word16 -> TF.I16 -> IO a) -> IO a +textUseAsPtr t@(Text _arr _off len) action = + allocaBytes (len * 2) $ \buf -> do + TF.unsafeCopyToPtr t buf + action (castPtr buf) (fromIntegral len) diff --git a/Util/Aeson.hs b/Util/Aeson.hs new file mode 100644 --- /dev/null +++ b/Util/Aeson.hs @@ -0,0 +1,195 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- FromJSON instance below is an orphan (deliberately) +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE CPP #-} + +module Util.Aeson + ( toJSONText + , toJSONByteString + , cStringToObject + , unsafeCStringToObject + , unsafeCStringLenToObject + , prettyJSON + , parseValueStrict' + , parseValueStrict + -- * Backwards compatibility + , ObjectKey + , KeyMap + , keyToText + , keysToTexts + , keyFromText + , objectToList + , objectFromList + , objectKeys + , objectToHashMap + , objectFromHashMap + , objectToHashMapText + , objectFromHashMapText + , emptyKeyMap + , insertKeyMap + , unionKeyMap + , keyMapSize + , lookupKeyMap + ) where + +import Data.Aeson +import Data.Aeson.Parser (value, value') +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson.Key +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Coerce +import Data.Type.Coercion +#endif +import Data.Aeson.Types (typeMismatch) +import Data.ByteString (ByteString) +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Lazy as LB +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import Foreign.C + +import Text.PrettyPrint +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Vector as Vector +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +-- | Converts a value to JSON, and returns it as a 'Text' +toJSONText :: ToJSON x => x -> Text.Text +toJSONText = Text.decodeUtf8 . toJSONByteString + +-- | Converts a value to JSON, and returns it as a 'ByteString' +toJSONByteString :: ToJSON x => x -> ByteString +toJSONByteString = LB.toStrict . encode + +-- | Since Aeson is lazily parsed, this assumes that that the memory +-- pointed to in the 'CString' will live throughout the liftime of the +-- returned object. If not, this potentially references freed memory. If +-- you cannot guarantee the lifetime, use 'cStringToObject'. +unsafeCStringToObject :: CString -> IO (Maybe Object) +unsafeCStringToObject s = decodeStrict <$> B.unsafePackCString s + +-- | like 'unsafeCStringToObject' but takes a length too +unsafeCStringLenToObject :: CString -> Int -> IO (Maybe Object) +unsafeCStringLenToObject s l = decodeStrict <$> B.unsafePackCStringLen (s,l) + +-- | Copies the 'CString' contents into Haskell, and then creates a +-- lazily parsed Aeson 'Object'. +cStringToObject :: CString -> IO (Maybe Object) +cStringToObject s = decodeStrict <$> B.packCString s + +-- | Convert a JSON value to a 'String' with indentation to make it +-- easier to read. +prettyJSON :: Value -> String +prettyJSON val = show (pp val) + where + pp :: Value -> Doc + pp Null = text "null" + pp (Bool b) = text $ if b then "true" else "false" + pp (String txt) = + text (Text.unpack $ Text.decodeUtf8 $ LB.toStrict $ encode (String txt)) + pp (Number i) = text (show i) + pp (Object hm) = + braces $ sep $ + punctuate (char ',') + [ sep [ pp (String (keyToText key)) <+> char ':', nest 2 (pp v) ] + | (key, v) <- HashMap.toList (objectToHashMap hm) ] + pp (Array arr) = + brackets $ sep $ punctuate (char ',') $ map pp $ Vector.toList arr + +-- eitherDecode family of function strictly requires that the Value is +-- either an object or an array. +-- This relaxes that restriction and allows other kinds of Values. +-- NOTE: this is fixed in latest aeson +parseValueStrict :: ByteString -> Either String Value +parseValueStrict = A.parseOnly + (A.skipSpace *> value <* A.skipSpace <* A.endOfInput) + +parseValueStrict' :: ByteString -> Either String Value +parseValueStrict' = A.parseOnly + (A.skipSpace *> value' <* A.skipSpace <* A.endOfInput) + +-- Orphan instance to make from/toJSON O(1) when converting from/to an Object +-- (aka HashMap Text Value). Otherwise the default instances provided +-- by Aeson will rebuild the HashMap. +-- +-- This needs to be not just OVERLAPPABLE, but INCOHERENT, because +-- otherwise a constraint "FromJSON (HashMap Text a)" doesn't have a +-- single most-specific instance to resolve to. INCOHERENT is ok; +-- the worst that can happen is that we lose the optimisation. +instance {-# INCOHERENT #-} FromJSON Object where + parseJSON (Object obj) = return obj + parseJSON other = typeMismatch "object" other + +-- Having same optimization for 'ToJSON' is still valuable when we cannot use +-- 'Object' directly, e.g., when we are calling a polymorphic function with +-- a @ToJSON a@ constraint. +instance {-# INCOHERENT #-} ToJSON Object where + toJSON = Object + +keyToText :: ObjectKey -> Text +keysToTexts :: [ObjectKey] -> [Text] -- zero-cost coercion +keyFromText :: Text -> ObjectKey +objectToList :: KeyMap v -> [(ObjectKey, v)] +objectFromList :: [(ObjectKey, v)] -> KeyMap v +objectKeys :: KeyMap v -> [ObjectKey] +objectToHashMap :: KeyMap v -> HashMap ObjectKey v +objectFromHashMap :: HashMap ObjectKey Value -> Object +objectToHashMapText :: KeyMap v -> HashMap Text v +objectFromHashMapText :: HashMap Text v -> KeyMap v +emptyKeyMap :: KeyMap v +insertKeyMap :: ObjectKey -> v -> KeyMap v -> KeyMap v +unionKeyMap :: KeyMap v -> KeyMap v -> KeyMap v +keyMapSize :: KeyMap v -> Int +lookupKeyMap :: ObjectKey -> KeyMap v -> Maybe v + +#if MIN_VERSION_aeson(2,0,0) +type ObjectKey = Key +type KeyMap = KeyMap.KeyMap +keyToText = toText +keysToTexts = case Key.coercionToText of + Just Coercion -> coerce + _ -> map keyToText +keyFromText = fromText +objectToList = KeyMap.toList +objectFromList = KeyMap.fromList +objectKeys = KeyMap.keys +objectToHashMap = KeyMap.toHashMap +objectFromHashMap = KeyMap.fromHashMap +objectToHashMapText = KeyMap.toHashMapText +objectFromHashMapText = KeyMap.fromHashMapText +emptyKeyMap = KeyMap.empty +insertKeyMap = KeyMap.insert +unionKeyMap = KeyMap.union +keyMapSize = KeyMap.size +lookupKeyMap = KeyMap.lookup +#else +type ObjectKey = Text +type KeyMap v = HashMap Text v +keyToText = id +keysToTexts = id +keyFromText = id +objectToList = HashMap.toList +objectFromList = HashMap.fromList +objectKeys = HashMap.keys +objectToHashMap = id +objectFromHashMap = id +objectToHashMapText = id +objectFromHashMapText = id +emptyKeyMap = HashMap.empty +insertKeyMap = HashMap.insert +unionKeyMap = HashMap.union +keyMapSize = HashMap.size +lookupKeyMap = HashMap.lookup +#endif diff --git a/Util/AllocLimit.hs b/Util/AllocLimit.hs new file mode 100644 --- /dev/null +++ b/Util/AllocLimit.hs @@ -0,0 +1,118 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Util.AllocLimit + ( limitAllocs + , limitAllocsThrow + , withAllocLimit + , withSavedAllocLimit + , withAllocCounter + , handleAllExceptions + ) where + +import GHC.Conc +import Data.Int +import Control.Exception + +-- | Impose an allocation limit on the given 'IO' action. If the +-- action exceeds the limit, then 'Nothing' will be returned. +limitAllocs :: Int64 -> IO a -> IO (Maybe a) +limitAllocs limit action = + handle (\AllocationLimitExceeded -> return Nothing) $ + Just <$> limitAllocsThrow limit action + +-- | Impose an allocation limit on the given 'IO' action. If the +-- action exceeds the limit, then 'AllocationLimitExceeded' will be +-- thrown. +limitAllocsThrow :: Int64 -> IO a -> IO a +limitAllocsThrow limit action = do + e <- handleAllExceptions (return . Left) $ + Right <$> withSavedAllocLimit limit action + either throwIO return e + +-- | Impose an allocation limit on the given 'IO' action. If the +-- action exceeds the limit, then 'AllocationLimitExceeded' will be +-- thrown. (Note: most uses should use 'limitAllocs' instead). +-- +-- Note that if this function throws an exception +-- ('AllocationLimitExceeded' or otherwise), even though there will be +-- no /more/ 'AllocationLimitExceeded' exceptions, there might be +-- multiple 'AllocationLimitExceeded' exceptions already in flight. +-- This happens as follows: the first exception gets thrown, which +-- causes an exception handler to run, which triggers another +-- 'AllocationLimitExceeded' exception, which doesn't get thrown +-- immediately because the exception handler is implicitly masked, and +-- so on. +-- +-- To deal with this we provide 'handleAllExceptions', which you +-- should wrap around 'withAllocLimit'. +-- +-- Note: this function clobbers the allocation counter, so +-- e.g. `Util.Timing.timeIt` will give bogus results if the +-- computation being measured calls `withAllocLimit`. To avoid this, +-- use `withSavedAllocLimit` instead. +withAllocLimit :: Int64 -> IO a -> IO a +withAllocLimit limit = + bracket_ + (do setAllocationCounter limit; enableAllocationLimit) + disableAllocationLimit + +-- | Like `withAllocLimit`, but does not clobber the allocation +-- counter. +withSavedAllocLimit :: Int64 -> IO a -> IO a +withSavedAllocLimit limit io = bracket set unset $ \_ -> io + where + set = do + prev <- getAllocationCounter + setAllocationCounter limit + enableAllocationLimit + return prev + unset prev = do + cur <- getAllocationCounter + disableAllocationLimit + setAllocationCounter (prev - (limit - cur)) + +-- | Sets the allocation counter for the given 'IO' action, then restores the +-- original counter value after the 'IO' action is done. +-- +-- Note that as opposed to 'withAllocLimit' this function provides no guarantee +-- that if the set alloc counter is consumed, an 'AllocationLimitExceeded' will +-- be thrown, that depends on whether 'enableAllocationLimit' has been called +-- or not. If that guarantee is something you need, use 'withAllocLimit', but be +-- mindful of the fact that 'withAllocLimit' calls should not be nested inside +-- each other while 'withAllocCounter' calls can. +-- +-- This function can be useful when there's a need to "isolate" certain +-- calls from the current allocation limit by setting a separate allocation +-- limit for them, then restoring the initial limit when done. +-- +-- Once this is done: T30781590. We will be able to use the new primitive in +-- 'withAllocLimit' and deprecate 'withAllocCounter' +withAllocCounter :: Int64 -> IO a -> IO a +withAllocCounter counter action = do + initialAllocCounter <- getAllocationCounter + bracket_ + (setAllocationCounter counter) + (setAllocationCounter initialAllocCounter) + action + +-- | Like 'Control.Exception.handle', but if there are pending async +-- exceptions, all are swallowed except for the last one, which is +-- passed to the handler. This is mainly for wrapping around +-- 'withAllocLimit', to ensure that no 'AllocationLimitExceeded' +-- exceptions can leak out. +-- +handleAllExceptions :: (SomeException -> IO a) -> IO a -> IO a +handleAllExceptions handler = handle errorHandler + where + errorHandler exn = + handle errorHandler $ do + allowInterrupt -- let any pending async exceptions throw + handler exn diff --git a/Util/Applicative.hs b/Util/Applicative.hs new file mode 100644 --- /dev/null +++ b/Util/Applicative.hs @@ -0,0 +1,14 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Applicative + ( concatMapM + ) where + +concatMapM :: (Applicative f) => (a -> f [b]) -> [a] -> f [b] +concatMapM f = fmap concat . traverse f diff --git a/Util/AsanAlloc.cpp b/Util/AsanAlloc.cpp new file mode 100644 --- /dev/null +++ b/Util/AsanAlloc.cpp @@ -0,0 +1,22 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include "Util/AsanAlloc.h" + +#include + +void* alignedAlloc(size_t alignment, size_t size) noexcept { +// GCC only supports ASAN aligned_alloc as of September 2014, which roughly +// corresponds to version 5 and above. This code can be deprecated once +// Facebook upgrade to GCC 5.x +#if __clang__ || __GNUC__ > 4 + return aligned_alloc(alignment, size); +#else + return memalign(alignment, size); +#endif +} diff --git a/Util/AsanAlloc.h b/Util/AsanAlloc.h new file mode 100644 --- /dev/null +++ b/Util/AsanAlloc.h @@ -0,0 +1,16 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include + +extern "C" { + +void* alignedAlloc(size_t alignment, size_t size) noexcept; +} diff --git a/Util/Async.hs b/Util/Async.hs new file mode 100644 --- /dev/null +++ b/Util/Async.hs @@ -0,0 +1,63 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- | This module provides some higher level concurrency facilities +module Util.Async + ( window_, + windowUnorderedReduce, + runHereOrConcurrently + ) where + +import Control.Concurrent.Async +import Control.Concurrent.Chan +import Control.Monad (forM_, replicateM_) + +-- | This function is similar to folly::window. It takes a list of input items +-- and launch a pool of `maxConcurrency` of workers to process them +window_ :: Int -> (a -> IO ()) -> [a] -> IO () +window_ maxConcurrency process tasks = do + queue <- newChan + forM_ tasks $ writeChan queue . Just + replicateM_ maxConcurrency $ writeChan queue Nothing + replicateConcurrently_ maxConcurrency $ runWorker queue process + where + runWorker :: Chan (Maybe a) -> (a -> IO ()) -> IO () + runWorker queue process' = do + token <- readChan queue + case token of + Just task -> do + process' task + runWorker queue process' + Nothing -> return () + + +-- | A variant of window function where we collect the result without +-- preserving the order +windowUnorderedReduce + :: Monoid b => Int -> (a -> IO b) -> [a] -> IO [b] +windowUnorderedReduce maxConcurrency process tasks = do + queue <- newChan + forM_ tasks $ writeChan queue . Just + replicateM_ maxConcurrency $ writeChan queue Nothing + replicateConcurrently maxConcurrency + $ runWorker queue mempty + where + runWorker queue acc = do + token <- readChan queue + case token of + Just task -> do + result <- process task + runWorker queue $ mappend result acc + Nothing -> return acc + +-- | A wrapper for 'mapConcurrently' so that a singleton list of +-- actions runs in this thread, instead of asynchronously +runHereOrConcurrently :: [IO a] -> IO [a] +runHereOrConcurrently [] = return [] +runHereOrConcurrently [x] = (:[]) <$> x +runHereOrConcurrently xs = mapConcurrently id xs diff --git a/Util/Bag.hs b/Util/Bag.hs new file mode 100644 --- /dev/null +++ b/Util/Bag.hs @@ -0,0 +1,53 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Bag + ( Bag -- Do not export constructors. + , singleton + , empty + , fromList + ) where + +import Data.Foldable (toList) + +-- | A bag of items which supports O(1) append +data Bag a + = EmptyBag + | OneItem a + | ConcatBags (Bag a) (Bag a) -- INVARIANT: Neither sub-bag is empty + +instance Semigroup (Bag a) where + (<>) EmptyBag y = y + (<>) x EmptyBag = x + (<>) x y = ConcatBags x y + +instance Monoid (Bag a) where + mempty = EmptyBag + +instance Foldable Bag where + foldr _ b EmptyBag = b + foldr f b (OneItem x) = f x b + foldr f b (ConcatBags x y) = foldr f (foldr f b y) x + +instance Functor Bag where + fmap _ EmptyBag = EmptyBag + fmap f (OneItem x) = OneItem $ f x + fmap f (ConcatBags x y) = ConcatBags (fmap f x) (fmap f y) + +singleton :: a -> Bag a +singleton x = OneItem x + +empty :: Bag a -> Bool +empty EmptyBag = True +empty _ = False + +fromList :: [a] -> Bag a +fromList = mconcat . map singleton + +instance Show a => Show (Bag a) where + show b = "fromList " ++ show (toList b) diff --git a/Util/Binary/Parser.hs b/Util/Binary/Parser.hs new file mode 100644 --- /dev/null +++ b/Util/Binary/Parser.hs @@ -0,0 +1,505 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Strict #-} + +module Util.Binary.Parser + ( Parser + , parse + , parseAndLeftover + , peekBS + , anyWord8 + , word8 + , getInt16be + , getInt16le + , getInt32be + , getInt32le + , getInt64be + , getInt64le + , getWord16be + , getWord16le + , getWord32be + , getWord32le + , getWord64be + , getWord64le + , skipN + , skipSpaces + , sepBy + , string + , signed + , peek + , double + , decimal + , getByteString + , takeWhile + ) where + +import Control.Applicative +#if __GLASGOW_HASKELL__ == 806 +import Control.Monad hiding (fail) +#else +import Control.Monad +#endif +#if __GLASGOW_HASKELL__ == 806 +import Control.Monad.Fail as Fail +#endif +import Control.Exception +import Util.Control.Exception (tryAll) + +import Data.Bits +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe as B +import qualified Data.ByteString as B +import qualified Data.ByteString.Lex.Integral as LexInt +import Data.Scientific (Scientific (..)) +import qualified Data.Scientific as Sci +import Data.Word + +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Data.FastMutInt +#else +import FastMutInt +#endif + +#if __GLASGOW_HASKELL__ == 806 +import GHC.Base hiding (fail) +#else +import GHC.Base +#endif +import GHC.Word +import GHC.Int + +#if __GLASGOW_HASKELL__ == 806 +import Prelude hiding (takeWhile, fail) +#else +import Prelude hiding (takeWhile) +#endif + +import System.IO.Unsafe (unsafeDupablePerformIO) + +data Env = Env {-# UNPACK #-} !ByteString + {-# UNPACK #-} !FastMutInt + +newtype Parser a = Parser { unParser :: Env -> IO a } + +instance Functor Parser where + fmap f m = Parser $ \env -> do + a <- unParser m env + return $ f a + {-# INLINE fmap #-} + +instance Applicative Parser where + pure a = Parser $ \_ -> return a + (<*>) = ap + {-# INLINE (<*>) #-} + +instance Alternative Parser where + empty = Parser $ \_ -> throwIO $ + ParseError "Thrift.Binary.Parser(Alternative).empty" + (<|>) f g = Parser $ \env@(Env _ mutPos) -> do + originalPos <- readFastMutInt mutPos + eitherA <- tryAll $ unParser f env + case eitherA of + Right a -> return a + Left _ -> do + writeFastMutInt mutPos originalPos + unParser g env + +newtype ParseError = ParseError String deriving Show + +instance Exception ParseError + +instance Monad Parser where + m >>= k = Parser $ \env -> do + a <- unParser m env + unParser (k a) env + {-# INLINE (>>=) #-} + +#if __GLASGOW_HASKELL__ > 804 +instance MonadFail Parser where +#endif + fail err = Parser $ \ (Env _ mutPos) -> do + pos <- readFastMutInt mutPos + throwIO $ ParseError + $ err ++ ". Failed reading at byte position " ++ show pos + +get :: Parser ByteString +get = Parser $ \(Env bs mutPos) -> do + pos <- readFastMutInt mutPos + return $ B.unsafeDrop pos bs + +getAndIncrementMutPos :: FastMutInt -> Int -> IO Int +getAndIncrementMutPos mutPos nBytes = do + pos <- readFastMutInt mutPos + writeFastMutInt mutPos (pos + nBytes) + return pos +{-# INLINE getAndIncrementMutPos #-} + +incrPos :: Int -> Parser () +incrPos nBytes= Parser $ \(Env _ mutPos) -> void $ + getAndIncrementMutPos mutPos nBytes + +parse :: Parser a -> ByteString -> Either String a +parse getter bs = + let + eitherA = unsafeDupablePerformIO $ do +#if __GLASGOW_HASKELL__ >= 902 + mutPos <- newFastMutInt 0 +#else + mutPos <- newFastMutInt + writeFastMutInt mutPos 0 +#endif + tryAll $ unParser getter $ Env bs mutPos in + case eitherA of + Right a -> Right a + Left err -> Left (show err) + +parseAndLeftover + :: Parser a -> ByteString -> Either String (a, ByteString) +parseAndLeftover p bs = parse p' bs + where p' = (,) <$> p <*> peekBS + +peekBS :: Parser ByteString +peekBS = get + +ensureN :: Int -> Parser Int +ensureN nBytes + | nBytes < 0 = fail $ "negative byte count: " ++ show nBytes + | otherwise = Parser $ \(Env bs mutPos) -> do + pos <- readFastMutInt mutPos + unless (nBytes <= B.length bs - pos) $ + fail "incomplete input" + return pos +{-# INLINE ensureN #-} + +anyWord8 :: Parser Word8 +anyWord8 = do + pos <- ensureN 1 + Parser $ \(Env bs mutPos) -> do + writeFastMutInt mutPos (pos + 1) + return $ B.unsafeIndex bs pos +{-# INLINE anyWord8 #-} + +getByteString :: Int -> Parser ByteString +getByteString nBytes = do + pos <- ensureN nBytes + Parser $ \(Env bs mutPos) -> do + writeFastMutInt mutPos (pos + nBytes) + return $ B.unsafeTake nBytes (B.unsafeDrop pos bs) +{-# INLINE getByteString #-} + +readN :: Int -> (ByteString -> a) -> Parser a +readN n f = f <$> getByteString n +{-# INLINE [0] readN #-} + +skipN :: Int -> Parser () +skipN nBytes = do + pos <- ensureN nBytes + Parser $ \(Env _ mutPos) -> writeFastMutInt mutPos (pos + nBytes) + +peek :: Parser Word8 +peek = do + pos <- ensureN 1 + Parser $ \(Env bs _) -> + return $ B.unsafeIndex bs pos +{-# INLINE peek #-} + +word8 :: Word8 -> Parser () +word8 w8 = do + myW8 <- anyWord8 + when (myW8 /= w8) $ + fail "word8" +{-# INLINE word8 #-} + +takeWhile :: (Word8 -> Bool) -> Parser ByteString +takeWhile p = do + bs <- get + let (want, _) = B.span p bs + incrPos $ B.length want + return want +{-# INLINE takeWhile #-} + +isSpace :: Word8 -> Bool +isSpace w = w == 32 || w - 9 <= 4 +{-# INLINE isSpace #-} + +skipSpaces :: Parser () +skipSpaces = do + bs <- get + let rest = B.dropWhile isSpace bs + incrPos $ B.length bs - B.length rest + +string :: ByteString -> Parser () +string bs = do + let l = B.length bs + myBs <- getByteString l + when (myBs /= bs) $ + fail "string" +{-# INLINE string #-} + + +-- | The parser @satisfy p@ succeeds for any byte for which the +-- predicate @p@ returns 'True'. Returns the byte that is actually +-- parsed. +-- +-- >digit = satisfy isDigit +-- > where isDigit w = w >= 48 && w <= 57 +-- +satisfy :: (Word8 -> Bool) -> Parser Word8 +satisfy p = do + w8 <- anyWord8 + unless (p w8) $ + fail "satisfy" + return w8 +{-# INLINE satisfy #-} + +-- | Similar to 'takeWhile', but requires the predicate to succeed on at least +-- one byte of input: it will fail if the predicate never returns 'True' or +-- reach the end of input +-- +takeWhile1 :: (Word8 -> Bool) -> Parser ByteString +takeWhile1 p = do + bs <- takeWhile p + if B.null bs then fail "takeWhile1" else return bs +{-# INLINE takeWhile1 #-} + + +#define MINUS 45 +#define PLUS 43 +#define LITTLE_E 101 +#define BIG_E 69 +#define DOT 46 + +-- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign +-- character. +-- +signed :: Num a => Parser a -> Parser a +signed p = do + w <- peek + if w == MINUS + then skipN 1 >> negate <$> p + else if w == PLUS then skipN 1 >> p else p +{-# SPECIALISE signed :: Parser Int -> Parser Int #-} +{-# SPECIALISE signed :: Parser Int8 -> Parser Int8 #-} +{-# SPECIALISE signed :: Parser Int16 -> Parser Int16 #-} +{-# SPECIALISE signed :: Parser Int32 -> Parser Int32 #-} +{-# SPECIALISE signed :: Parser Int64 -> Parser Int64 #-} +{-# SPECIALISE signed :: Parser Integer -> Parser Integer #-} + +-- | Decimal digit predicate. +-- +isDigit :: Word8 -> Bool +isDigit w = w - 48 <= 9 +{-# INLINE isDigit #-} + +-- | Parse and decode an unsigned decimal number. +-- +decimal :: Integral a => Parser a +decimal = do + bs <- takeWhile1 isDigit + return $! LexInt.readDecimal_ bs +{-# SPECIALISE decimal :: Parser Int #-} +{-# SPECIALISE decimal :: Parser Int8 #-} +{-# SPECIALISE decimal :: Parser Int16 #-} +{-# SPECIALISE decimal :: Parser Int32 #-} +{-# SPECIALISE decimal :: Parser Int64 #-} +{-# SPECIALISE decimal :: Parser Integer #-} +{-# SPECIALISE decimal :: Parser Word #-} +{-# SPECIALISE decimal :: Parser Word8 #-} +{-# SPECIALISE decimal :: Parser Word16 #-} +{-# SPECIALISE decimal :: Parser Word32 #-} +{-# SPECIALISE decimal :: Parser Word64 #-} + +double :: Parser Double +double = scientifically Sci.toRealFloat + +-- | Parse a scientific number and convert to result using a user supply +-- function. +-- +-- The syntax accepted by this parser is the same as for 'double'. +-- +scientifically :: (Scientific -> a) -> Parser a +scientifically h = do + sign <- peek + when (sign == PLUS || sign == MINUS) (skipN 1) + intPart <- decimal + sci <- (do fracDigits <- word8 DOT >> takeWhile1 isDigit + let e' = B.length fracDigits + intPart' = intPart * (10 ^ e') + fracPart = LexInt.readDecimal_ fracDigits + parseE (intPart' + fracPart) e' + ) <|> parseE intPart 0 + + if sign /= MINUS then return $! h sci else return $! h (negate sci) + where + parseE c e = + (do _ <- satisfy (\w -> w == LITTLE_E || w == BIG_E) + Sci.scientific c . subtract e <$> signed decimal) + <|> return (Sci.scientific c (negate e)) + {-# INLINE parseE #-} +{-# INLINE scientifically #-} + +sepBy :: Alternative f => f a -> f s -> f [a] +sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure [] +{-# SPECIALIZE sepBy :: Parser a -> Parser s -> Parser [a] #-} + +sepBy1 :: Alternative f => f a -> f s -> f [a] +sepBy1 p s = go + where go = liftA2 (:) p ((s *> go) <|> pure []) +{-# SPECIALIZE sepBy1 :: Parser a -> Parser s -> Parser [a] #-} + +------------------------------------------------------------------------ +-- Following code is copied from Data.Binary.Get +------------------------------------------------------------------------ +type Get a = Parser a + +-- force GHC to inline getWordXX +{-# RULES +"getWord16be/readN" getWord16be = readN 2 word16be +"getWord16le/readN" getWord16le = readN 2 word16le +"getWord32be/readN" getWord32be = readN 4 word32be +"getWord32le/readN" getWord32le = readN 4 word32le +"getWord64be/readN" getWord64be = readN 8 word64be +"getWord64le/readN" getWord64le = readN 8 word64le #-} + +-- | Read a Word16 in big endian format +getWord16be :: Get Word16 +getWord16be = readN 2 word16be + +word16be :: B.ByteString -> Word16 +word16be = \s -> + (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|. + (fromIntegral (s `B.unsafeIndex` 1)) +{-# INLINE[2] getWord16be #-} +{-# INLINE word16be #-} + +-- | Read a Word16 in little endian format +getWord16le :: Get Word16 +getWord16le = readN 2 word16le + +word16le :: B.ByteString -> Word16 +word16le = \s -> + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) +{-# INLINE[2] getWord16le #-} +{-# INLINE word16le #-} + +-- | Read a Word32 in big endian format +getWord32be :: Get Word32 +getWord32be = readN 4 word32be + +word32be :: B.ByteString -> Word32 +word32be = \s -> + (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 8) .|. + (fromIntegral (s `B.unsafeIndex` 3) ) +{-# INLINE[2] getWord32be #-} +{-# INLINE word32be #-} + +-- | Read a Word32 in little endian format +getWord32le :: Get Word32 +getWord32le = readN 4 word32le + +word32le :: B.ByteString -> Word32 +word32le = \s -> + (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) +{-# INLINE[2] getWord32le #-} +{-# INLINE word32le #-} + +-- | Read a Word64 in big endian format +getWord64be :: Get Word64 +getWord64be = readN 8 word64be + +word64be :: B.ByteString -> Word64 +word64be = \s -> + (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 8) .|. + (fromIntegral (s `B.unsafeIndex` 7) ) +{-# INLINE[2] getWord64be #-} +{-# INLINE word64be #-} + +-- | Read a Word64 in little endian format +getWord64le :: Get Word64 +getWord64le = readN 8 word64le + +word64le :: B.ByteString -> Word64 +word64le = \s -> + (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) +{-# INLINE[2] getWord64le #-} +{-# INLINE word64le #-} + +-- | Read an Int16 in big endian format. +getInt16be :: Get Int16 +getInt16be = fromIntegral <$> getWord16be +{-# INLINE getInt16be #-} + +-- | Read an Int32 in big endian format. +getInt32be :: Get Int32 +getInt32be = fromIntegral <$> getWord32be +{-# INLINE getInt32be #-} + +-- | Read an Int64 in big endian format. +getInt64be :: Get Int64 +getInt64be = fromIntegral <$> getWord64be +{-# INLINE getInt64be #-} + +-- | Read an Int16 in little endian format. +getInt16le :: Get Int16 +getInt16le = fromIntegral <$> getWord16le +{-# INLINE getInt16le #-} + +-- | Read an Int32 in little endian format. +getInt32le :: Get Int32 +getInt32le = fromIntegral <$> getWord32le +{-# INLINE getInt32le #-} + +-- | Read an Int64 in little endian format. +getInt64le :: Get Int64 +getInt64le = fromIntegral <$> getWord64le +{-# INLINE getInt64le #-} + +------------------------------------------------------------------------ +-- Unchecked shifts +shiftl_w16 :: Word16 -> Int -> Word16 +#if __GLASGOW_HASKELL__ >= 902 +shiftl_w16 (W16# w) (I# i) = W16# (wordToWord16# (word16ToWord# w `uncheckedShiftL#` i)) +#else +shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) +#endif + +shiftl_w32 :: Word32 -> Int -> Word32 +#if __GLASGOW_HASKELL__ >= 902 +shiftl_w32 (W32# w) (I# i) = W32# (wordToWord32# (word32ToWord# w `uncheckedShiftL#` i)) +#else +shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) +#endif + +shiftl_w64 :: Word64 -> Int -> Word64 +#if WORD_SIZE_IN_BITS < 64 +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) +#else +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) +#endif diff --git a/Util/Bits.hs b/Util/Bits.hs new file mode 100644 --- /dev/null +++ b/Util/Bits.hs @@ -0,0 +1,28 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE MagicHash #-} +module Util.Bits (bitLength) where + +import GHC.Exts +import GHC.Integer.Logarithms + +-- | The number of bits in the minimal two's-complement +-- representation, excluding a sign bit. +-- +-- > bitLength 3 = 2 +-- > bitLength 4 = 3 +-- +-- See http://mathworld.wolfram.com/BitLength.html for more information. +bitLength :: Integral a => a -> Int +bitLength = integerBitLength . toInteger + where + integerBitLength n + | n < 0 = integerBitLength $ -1 - n + | n == 0 = 0 + | otherwise = I# (1# +# integerLog2# n) diff --git a/Util/Buffer.hs b/Util/Buffer.hs new file mode 100644 --- /dev/null +++ b/Util/Buffer.hs @@ -0,0 +1,233 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +-- | Byte buffers in ST with amortized O(1) append. They are significantly +-- faster and more memory efficient than things built on top of lazy +-- bytestrings. + +module Util.Buffer + ( Buffer, Fill + , liftST + , alloc + , ascii + , byte + , byteString + , fillByteString + ) +where + +import Control.Exception (assert) +import Control.Monad.Primitive +import Control.Monad.ST (ST) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BSI +import Data.Char (isAscii) +#if !MIN_VERSION_primitive(0,7,0) +import Data.Primitive.Addr (Addr(..)) +#endif +import Data.Primitive.ByteArray +import GHC.Exts + ( Int(..), plusAddr# + , copyAddrToByteArray#, shrinkMutableByteArray# + , unsafeCoerce# + ) +import GHC.ForeignPtr +import GHC.Ptr (Ptr(..), plusPtr) +import GHC.Word (Word8(..)) + +-- | An exponentially growing buffer of bytes in ST with amortized O(1) append. +-- +-- Invariants: +-- +-- > bufLen buf <= bufRes buf +-- > bufRes buf <= bufCap buf +-- > bufCap buf > 0 +-- +data Buffer s = Buffer + { -- | The actual bytes + bufData :: {-# UNPACK #-} !(MutableByteArray s) + + -- | How much of the buffer has been filled + , bufLen :: {-# UNPACK #-} !Int + + -- | How much of the buffer has been reserved + , bufRes :: {-# UNPACK #-} !Int + + -- | Capacity of the buffer (i.e., length of the MutableByteArray) + , bufCap :: {-# UNPACK #-} !Int + } + +-- | An ST-based monad for filling. +data Fill s a = Fill + { -- | How many bytes to reserve - _fillIt assumes that the Buffer will have + -- at least that much free space. This helps avoid repeated calls to + -- 'reserve'. + _fillRes :: {-# UNPACK #-} !Int + + -- | The function that fills the Buffer. The old Buffer may not be used + -- after this function has been invoked. + , _fillIt :: Buffer s -> ST s (Buffer s, a) + } + +instance Functor (Fill s) where + {-# INLINE fmap #-} + fmap f (Fill n h) = Fill n $ fmap (fmap (fmap f)) h + +instance Applicative (Fill s) where + {-# INLINE pure #-} + pure x = Fill 0 $ \ !buf -> return (buf, x) + + {-# INLINE (*>) #-} + Fill m f *> Fill n g = Fill (m+n) $ \ !buf -> do + (!buf,_) <- f buf + g buf + + {-# INLINE (<*>) #-} + Fill m f <*> Fill n g = Fill (m+n) $ \ !buf -> do + (!buf, h) <- f buf + (!buf, x) <- g buf + return (buf, h x) + +instance Monad (Fill s) where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + Fill m f >>= g = Fill m $ \ !buf -> do + (!buf, x) <- f buf + fill buf $ g x + +-- | Fill a buffer. The old buffer may not be used after this. +fill :: Buffer s -> Fill s a -> ST s (Buffer s, a) +{-# INLINE fill #-} +fill !buf (Fill n f) = do + buf <- reserve buf n + f buf + +-- | Lift 'ST' actions into 'Fill'. +liftST :: ST s a -> Fill s a +{-# INLINE liftST #-} +liftST st = Fill 0 $ \ !buf -> (,) buf <$> st + +-- | Write into the buffer. +write + :: Int -- ^ max number of bytes to write + -> (MutableByteArray s -> Int -> ST s Int) + -- ^ takes the raw array and an initial offset and returns the offset + -- one past the last byte it wrote + -> Fill s () +{-# INLINE write #-} +write n f = Fill n $ \(Buffer arr len res cap) -> do + len' <- f arr len + return (Buffer arr len' res cap, ()) + +-- | Write an ASCII (<=127) character into the buffer. +ascii :: Char -> Fill s () +{-# INLINE ascii #-} +ascii c = assert (isAscii c) $ byte $ fromIntegral $ fromEnum c + +-- | Write a byte into the buffer. +byte :: Word8 -> Fill s () +{-# INLINE byte #-} +byte !x = write 1 $ \arr i -> do + writeByteArray arr i x + return (i+1) + +-- | Write a 'ByteString' into the buffer. +byteString :: ByteString -> Fill s () +{-# INLINE byteString #-} +byteString (BSI.PS (ForeignPtr addr# r) (I# k#) n@(I# n#)) = + write n $ \(MutableByteArray arr#) i@(I# i#) -> do + -- primitive doesn't wrap this so no point in trying to make things nice + primitive_ (copyAddrToByteArray# (plusAddr# addr# k#) arr# i# n#) + touch r + return (i+n) + +-- | Write into the buffer using a pointer. Writing more than the max number of +-- bytes will cause segfaults! +alloc + :: Int -- ^ max number of bytes to write + -> (forall s. Ptr Word8 -> ST s Int) + -- ^ takes a pointer to the free space and returns the number of bytes + -- written + -> Fill s () +{-# INLINE alloc #-} +alloc !n f = write n $ \arr i -> do +#if MIN_VERSION_primitive(0,7,0) + let p = mutableByteArrayContents arr + k <- f (p `plusPtr` i) +#else + let !(Addr addr#) = mutableByteArrayContents arr + k <- f (Ptr addr# `plusPtr` i) +#endif + assert (k <= n) $ return () + touch arr + return (i+k) + +-- | Fill a buffer and turn it into a 'ByteString'. +fillByteString + :: Int -- ^ initial capacity + -> Fill s () -- ^ data + -> ST s ByteString +{-# INLINE fillByteString #-} +fillByteString n f = do + buf <- new n + (buf, _) <- fill buf f + unsafeFreezeByteString buf + +-- | Create a new buffer with the given initial capacity. +new :: Int -> ST s (Buffer s) +new !cap = do + let !c = max cap 1 + arr <- newPinnedByteArray c + return Buffer + { bufData = arr + , bufLen = 0 + , bufRes = 0 + , bufCap = c + } + +reserve :: Buffer s -> Int -> ST s (Buffer s) +reserve (Buffer arr len res cap) !n + | wanted <= cap = return $ Buffer arr len wanted cap + | otherwise = do + let !bcap = cap + max cap (wanted - cap) + brr <- resize arr len bcap + return $ Buffer brr len wanted bcap + where + !wanted = res + n + +unsafeFreezeByteString :: Buffer s -> ST s ByteString +unsafeFreezeByteString (Buffer arr@(MutableByteArray arr#) len _ _) = do + shrink arr len + case mutableByteArrayContents arr of +#if MIN_VERSION_primitive(0,7,0) + Ptr addr# -> +#else + Addr addr# -> +#endif + return $ BSI.fromForeignPtr + (ForeignPtr addr# (PlainPtr (unsafeCoerce# arr#))) + 0 + len + +resize :: MutableByteArray s -> Int -> Int -> ST s (MutableByteArray s) +{-# INLINE resize #-} +resize arr len cap = do + brr <- newPinnedByteArray cap + copyMutableByteArray brr 0 arr 0 len + return brr + +shrink :: MutableByteArray s -> Int -> ST s () +shrink (MutableByteArray arr#) (I# n#) = + -- shrinkMutableByteArray isn't wrapped by primitive + -- NOTE: we assume that shrinking never unpins + primitive_ (shrinkMutableByteArray# arr# n#) diff --git a/Util/Build.hs b/Util/Build.hs new file mode 100644 --- /dev/null +++ b/Util/Build.hs @@ -0,0 +1,13 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Build + ( Build + ) where + +type Build a = a -> a diff --git a/Util/ByteString.hs b/Util/ByteString.hs new file mode 100644 --- /dev/null +++ b/Util/ByteString.hs @@ -0,0 +1,126 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +{-# LANGUAGE CPP #-} + +module Util.ByteString + ( newCStringFromLazyByteString + , useLazyByteStringAsCString + , intToByteString + , useAsCString + , useAsCStringLen + , useByteStringsAsCStrings + , bsListAsCStrLenArr + , unsafeBsListAsCStrLenArr + ) where + +import Control.Arrow (left, second) +import Control.Monad +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString as BS +import Foreign +import Foreign.C + +import Data.ByteString.Builder +import Data.ByteString.Builder.Extra +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.Attoparsec.ByteString.Char8 as Atto +import qualified Data.Text as Text + +import qualified Util.ASan as ASan + +-- | Uses a lazy 'ByteString' as a NUL-terminated 'CString'. +useLazyByteStringAsCString + :: Lazy.ByteString -> (CString -> IO a) -> IO a +useLazyByteStringAsCString = allocateAndCopy allocaBytes + +-- | Copies a lazy 'ByteString' and adds a terminating NUL. The +-- resulting 'CString' must be 'free'd. +newCStringFromLazyByteString :: Lazy.ByteString -> IO CString +newCStringFromLazyByteString = flip (allocateAndCopy mallocBytes') return + +useAsCStringLen :: BS.ByteString -> (CStringLen -> IO a) -> IO a +-- TODO(T24195918): We need to do this for ABI compatibility between +-- sigma.service and sigma.service.asan. Codemod to __SANITIZE_ADDRESS__ +-- to enable ASAN checks for Haskell allocations. +#ifdef __HASKELL_SANITIZE_ADDRESS__ +useAsCStringLen = ASan.byteStringWithCStringLen +#else +useAsCStringLen = BS.useAsCStringLen +#endif + +useAsCString :: BS.ByteString -> (CString -> IO a) -> IO a +#ifdef __HASKELL_SANITIZE_ADDRESS__ +useAsCString = ASan.byteStringWithCString +#else +useAsCString = BS.useAsCString +#endif + +-- | Allocates space for a lazy 'ByteString' and NUL terminator, then +-- copies all its chunks into the buffer. +allocateAndCopy + :: (Int -> (CString -> IO b) -> IO b) + -> Lazy.ByteString + -> (CString -> IO b) + -> IO b +allocateAndCopy allocate lbs action = allocate (len + 1) $ \dst -> do + copyChunksTo dst lbs + pokeByteOff dst len (0::CChar) + action dst + + where + len :: Int + len = fromIntegral (Lazy.length lbs) + + copyChunksTo :: Ptr a -> Lazy.ByteString -> IO () + copyChunksTo dst = foldM_ copyChunkTo 0 . Lazy.toChunks + where + copyChunkTo :: Int -> Strict.ByteString -> IO Int + copyChunkTo off bs = BS.unsafeUseAsCStringLen bs $ \(src, chunkLen) -> do + copyBytes (dst `plusPtr` off) src chunkLen + return (off + chunkLen) + +mallocBytes' :: Int -> (Ptr a -> IO b) -> IO b +mallocBytes' size action = mallocBytes size >>= action + +lengthMinInt :: Int +lengthMinInt = length . show $ (minBound :: Int) + +-- | Cheap (fast, low memory) conversion of Ints into an +-- ASCII/UTF8-encoded lazy ByteString. +intToByteString :: Int -> Lazy.ByteString +intToByteString = + toLazyByteStringWith (untrimmedStrategy lengthMinInt 0) Lazy.empty . intDec + +useByteStringsAsCStrings :: [BS.ByteString] -> (Ptr CString -> IO a) -> IO a +useByteStringsAsCStrings bs f = go bs [] + where go (t:ts) acc = useAsCString t $ go ts . (:acc) + go [] acc = withArray0 nullPtr (reverse acc) f + +bsListAsCStrLenArr :: [BS.ByteString] + -> (Ptr CString -> Ptr CSize -> CSize -> IO a) + -> IO a +bsListAsCStrLenArr bs f = go bs [] + where go (t:ts) acc = useAsCStringLen t $ go ts . (:acc) + go [] acc = withArrayLen strs $ \len strPtr -> + withArray lens $ \lenPtr -> + f strPtr lenPtr (fromIntegral len) + where (strs, lens) = second (map fromIntegral) $ unzip $ reverse acc + +unsafeBsListAsCStrLenArr :: [BS.ByteString] + -> (Ptr CString -> Ptr CSize -> CSize -> IO a) + -> IO a +unsafeBsListAsCStrLenArr bs f = go bs [] + where go (t:ts) acc = BS.unsafeUseAsCStringLen t $ go ts . (:acc) + go [] acc = withArrayLen strs $ \len strPtr -> + withArray lens $ \lenPtr -> + f strPtr lenPtr (fromIntegral len) + where (strs, lens) = second (map fromIntegral) $ unzip $ reverse acc diff --git a/Util/Concurrent.hs b/Util/Concurrent.hs new file mode 100644 --- /dev/null +++ b/Util/Concurrent.hs @@ -0,0 +1,103 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP #-} +module Util.Concurrent + ( concurrently3 + , concurrently4 + , concurrently5 + , concurrently6 + , concurrently7 + -- * ThreadLock + , ThreadLock + , newThreadLock + , withThreadLock + -- * Caching + , cacheSuccess + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad (void) +import Control.Monad.IO.Class + +#if __GLASGOW_HASKELL__ >= 902 +import Control.Monad.Catch +#else +import Exception (ExceptionMonad(..)) +#endif + +c :: IO a -> IO b -> IO (a, b) +c = concurrently + +concurrently3 :: IO t1 -> IO t2 -> IO t3 -> IO (t1, t2, t3) +concurrently3 a1 a2 a3 = flatten3 <$> a1 `c` a2 `c` a3 + +concurrently4 :: IO t1 -> IO t2 -> IO t3 -> IO t4 -> IO (t1, t2, t3, t4) +concurrently4 a1 a2 a3 a4 = flatten4 <$> a1 `c` a2 `c` a3 `c` a4 + +concurrently5 :: IO t1 -> IO t2 -> IO t3 -> IO t4 -> IO t5 + -> IO (t1, t2, t3, t4, t5) +concurrently5 a1 a2 a3 a4 a5 = flatten5 <$> a1 `c` a2 `c` a3 `c` a4 `c` a5 + +concurrently6 :: IO t1 -> IO t2 -> IO t3 -> IO t4 -> IO t5 -> IO t6 + -> IO (t1, t2, t3, t4, t5, t6) +concurrently6 a1 a2 a3 a4 a5 a6 = + flatten6 <$> a1 `c` a2 `c` a3 `c` a4 `c` a5 `c` a6 + +concurrently7 :: IO t1 -> IO t2 -> IO t3 -> IO t4 -> IO t5 -> IO t6 -> IO t7 + -> IO (t1, t2, t3, t4, t5, t6, t7) +concurrently7 a1 a2 a3 a4 a5 a6 a7 = + flatten7 <$> a1 `c` a2 `c` a3 `c` a4 `c` a5 `c` a6 `c` a7 + +flatten3 ((a1, a2), a3) = (a1, a2, a3) +flatten4 (((a1, a2), a3), a4) = (a1, a2, a3, a4) +flatten5 ((((a1, a2), a3), a4), a5) = (a1, a2, a3, a4, a5) +flatten6 (((((a1, a2), a3), a4), a5), a6) = (a1, a2, a3, a4, a5, a6) +flatten7 ((((((a1, a2), a3), a4), a5), a6), a7) = (a1, a2, a3, a4, a5, a6, a7) + +newtype ThreadLock = ThreadLock (IO (IO ())) + +newThreadLock :: IO ThreadLock +newThreadLock = do + mvar <- newEmptyMVar + return $ ThreadLock $ do + ours <- myThreadId + theirs <- tryReadMVar mvar + if theirs == Just ours + then return $ return () -- we are holding the lock, so this is noop + else do + putMVar mvar ours + return $ void $ takeMVar mvar + +-- | withThreadLock guarantees that only one thread holds the lock at the same +-- time. It can be nested so it is safe to use it in a recursive function. +#if __GLASGOW_HASKELL__ >= 902 +withThreadLock :: (MonadIO m, MonadMask m) => ThreadLock -> m a -> m a +withThreadLock (ThreadLock takeIO) action = do + fmap fst $ generalBracket (liftIO takeIO) (\releaseIO _ -> liftIO releaseIO) $ const action +#else +withThreadLock :: ExceptionMonad m => ThreadLock -> m a -> m a +withThreadLock (ThreadLock takeIO) action = do + gbracket (liftIO takeIO) (\releaseIO -> liftIO releaseIO) $ const action +#endif + +-- | Build an IO action that will cache its result the first time it +-- runs successfullly to completion. If it fails with an exception, +-- the exception is re-raised, but the IO action will be attempted +-- again the next time it is invoked. +-- +-- Like `Control.Concurrent.Extra.once`, but without caching exceptions. +-- +cacheSuccess :: IO a -> IO (IO a) +cacheSuccess act = do + m <- newMVar Nothing + return $ modifyMVar m $ \x -> case x of + Nothing -> do a <- act; return (Just a, a) + Just a -> return (Just a, a) diff --git a/Util/Control/Exception.hs b/Util/Control/Exception.hs new file mode 100644 --- /dev/null +++ b/Util/Control/Exception.hs @@ -0,0 +1,141 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Util.Control.Exception + ( -- * Catching all exceptions safely + catchAll + , handleAll + , tryAll + -- * Exception predicates + , isSyncException + , isAsyncException + -- * Other utilities + , throwLeftIO + , throwLeftExceptionIO + , tryBracket + , tryFinally + , onSomeException + , afterwards + , swallow + , logExceptions + ) where + +#if __GLASGOW_HASKELL__ == 804 +import Control.Exception ( SomeAsyncException(..) ) +#endif +import Control.Exception.Lifted +import Control.Monad +import Control.Monad.Trans.Control + +import GHC.Stack (HasCallStack, withFrozenCallStack) + +import Util.Log + +-- | Catch all exceptions *except* asynchronous exceptions +-- (technically, children of 'SomeAsyncException'). Catching +-- asynchronous exceptions is almost never what you want to do: it can +-- result in ignoring 'ThreadKilled' which can lead to deadlock (see +-- ). +-- +-- Use this instead of the raw 'catch' when catching 'SomeException'. +-- +catchAll :: MonadBaseControl IO m => m a -> (SomeException -> m a) -> m a +catchAll action handler = + action `catch` \ex -> + case fromException ex of + Just (_ :: SomeAsyncException) -> throwIO ex + Nothing -> handler ex + +-- | The "try" version of 'catchAll' +tryAll :: MonadBaseControl IO m => m a -> m (Either SomeException a) +tryAll action = (Right <$> action) `catchAll` (return . Left) + +-- | Flipped version of 'catchAll' +handleAll :: MonadBaseControl IO m => (SomeException -> m a) -> m a -> m a +handleAll = flip catchAll + +throwLeftIO :: Exception e => Either e a -> IO a +throwLeftIO = throwLeftExceptionIO id + +throwLeftExceptionIO :: Exception e => (a -> e) -> Either a b -> IO b +throwLeftExceptionIO mkEx e = either (throwIO . mkEx) pure e + +-- | Detect 'SomeAsyncException' wrapped exceptions versus all others +isSyncException :: Exception e => e -> Bool +isSyncException e = case fromException (toException e) of + Just (SomeAsyncException _) -> False + Nothing -> True + +-- | Detect 'SomeAsyncException' wrapped exceptions versus all others +isAsyncException :: Exception e => e -> Bool +isAsyncException = not . isSyncException + +-- | A variant of 'bracket' where the release action also gets to see whether +-- the inner action succeeded or threw an exception. +tryBracket + :: IO a -- ^ run first + -> (a -> Either SomeException b -> IO ()) -- ^ run finally + -> (a -> IO b) -- ^ run in between + -> IO b +tryBracket before after inner = + mask $ \restore -> do + a <- before + r <- restore (inner a) `catch` \ex -> do + after a (Left ex) + throwIO ex + _ <- after a (Right r) + return r + +-- | A variant of 'finally' where the final action also gets to see whether +-- the first action succeeded or threw an exception. +tryFinally + :: IO a -- ^ run first + -> (Either SomeException a -> IO ()) -- ^ run finally + -> IO a +tryFinally inner after = + mask $ \restore -> do + r <- restore inner `catch` \ex -> do + after (Left ex) + throwIO ex + _ <- after (Right r) + return r + +-- | Execute an action and invoke a function if it throws any exception. The +-- exception is then rethrown. Any exceptions from the function are ignored +-- (but logged). +onSomeException :: HasCallStack => IO a -> (SomeException -> IO ()) -> IO a +onSomeException io f = io `catch` \exc -> do + withFrozenCallStack $ swallow $ f exc + throwIO exc + +-- | Execute an action and do something with its result even if it throws a +-- synchronous exception. Any exceptions from the function are ignored +-- (but logged). +afterwards :: HasCallStack => IO a -> (Either SomeException a -> IO ()) -> IO a +afterwards io f = do + r <- tryAll io + withFrozenCallStack $ swallow $ f r + case r of + Right result -> return result + Left exc -> throwIO exc + +-- | Execute an action and drop its result or any synchronous +-- exception it throws. Exceptions are logged. +swallow :: HasCallStack => IO a -> IO () +swallow io = void io `catchAll` \exc -> do + withFrozenCallStack $ logError $ "swallowing exception: " ++ show exc + +-- | Log and rethrow all synchronous exceptions arising from an +-- IO computation. +logExceptions :: HasCallStack => (String -> String) -> IO a -> IO a +logExceptions f io = withFrozenCallStack $ + io `onSomeException` (logError . f . show) diff --git a/Util/Control/Exception/CallStack.hs b/Util/Control/Exception/CallStack.hs new file mode 100644 --- /dev/null +++ b/Util/Control/Exception/CallStack.hs @@ -0,0 +1,40 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- | Adds support to work with exceptions that pack a rendered call stack. +module Util.Control.Exception.CallStack ( + throwIO, throwSTM, +) where + +import Control.Concurrent.STM (STM) +import qualified Control.Concurrent.STM as STM +import qualified Control.Exception as E +import Data.Text (Text, pack) +import GHC.Stack ( + HasCallStack, + callStack, + currentCallStack, + prettyCallStack, + renderStack, + withFrozenCallStack, + ) + +type CallStack = Text + +throwIO :: (E.Exception e, HasCallStack) => (CallStack -> e) -> IO a +throwIO mkException = withFrozenCallStack $ do + ccs <- currentCallStack + let stack + | null ccs = prettyCallStack callStack + | otherwise = renderStack ccs + E.throw $ mkException $ pack stack + +throwSTM :: (E.Exception e, HasCallStack) => (CallStack -> e) -> STM a +throwSTM mkException = withFrozenCallStack $ do + let stack = prettyCallStack callStack + STM.throwSTM $ mkException $ pack stack diff --git a/Util/Control/Monad.hs b/Util/Control/Monad.hs new file mode 100644 --- /dev/null +++ b/Util/Control/Monad.hs @@ -0,0 +1,33 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Control.Monad + ( whenMonoid + , whenDefault + , whenMaybe + , firstMLazy + ) where + +whenDefault :: Monad m => Bool -> a -> m a -> m a +whenDefault cond def monad = + if cond then monad else return def + +whenMaybe :: Monad m => Bool -> m (Maybe a) -> m (Maybe a) +whenMaybe b = whenDefault b Nothing + +whenMonoid :: (Monad m, Monoid a) => Bool -> m a -> m a +whenMonoid b = whenDefault b mempty + +-- | Performs the operations sequentially, and returns the first non-Nothing +-- value or throws the first exception immediately, whichever comes first. +-- +-- Note: this serializes all the operations, only use this if you know +-- what you're doing. +-- +firstMLazy :: (Foldable f, Monad m) => f (m (Maybe a)) -> m (Maybe a) +firstMLazy = foldr (\i j -> maybe j (pure . Just) =<< i) (pure Nothing) diff --git a/Util/Defer.hs b/Util/Defer.hs new file mode 100644 --- /dev/null +++ b/Util/Defer.hs @@ -0,0 +1,45 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Defer ( + Defer, Embed(..), now, later, immediately, lift +) where + +import Control.Applicative +import Control.Monad.Catch +import Control.Monad.STM +import Control.Monad.State.Strict + +-- | Used to link an STM transaction and deferred IO actions to be run when that +-- transaction has been completed. +newtype Defer io stm a = Defer (StateT (io ()) stm a) + deriving( + Functor, Applicative, Alternative, Monad, + MonadTrans, MonadThrow, MonadCatch) + +-- | Run a given STM transaction inside a 'Defer'. +now :: Monad stm => stm a -> Defer io stm a +now = lift + +-- | Used inside 'immediately' actions to append deferred IO actions to run +-- after the STM transaction has been completed. +later :: (Applicative io, Monad stm) => io () -> Defer io stm () +later io = Defer $ modify' (*> io) + +class Embed m1 m2 where + embed :: m1 a -> m2 a + +instance Embed STM IO where + embed = atomically + +-- | Run an STM transaction and then its deferred IO action. +immediately :: (Monad io, Monad stm, Embed stm io) => Defer io stm a -> io a +immediately (Defer action) = do + (x,deferred) <- embed $ runStateT action $ return () + deferred + return x diff --git a/Util/Encoding.hs b/Util/Encoding.hs new file mode 100644 --- /dev/null +++ b/Util/Encoding.hs @@ -0,0 +1,28 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Encoding where + +import GHC.IO.Encoding + ( setForeignEncoding + , setLocaleEncoding + , utf8 + ) + +-- | Set the foreign/locale encoding used by GHC +-- If affects: +-- 1. Any handle in text mode that has not an explicit encoding set +-- including stdin, stdout and stderr +-- 2. Marshalling `String` to `CString` via functions in `Foreign.C.String` +setDefaultEncodingToUTF8 :: IO () +setDefaultEncodingToUTF8 = do + setForeignEncoding utf8 + setLocaleEncoding utf8 + +foreign export ccall "hs_setDefaultEncodingToUTF8" + setDefaultEncodingToUTF8 :: IO () diff --git a/Util/Err.hs b/Util/Err.hs new file mode 100644 --- /dev/null +++ b/Util/Err.hs @@ -0,0 +1,24 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Err + ( Err + , errCtx + , err + ) where + +-- | An error monad with multi-line nested error messages +type Err a = Either [String] a + +err :: String -> Err a +err s = Left [s] + +errCtx :: String -> Err a -> Err a +errCtx str e = case e of + Left e' -> Left (str : map (" " ++) e') + Right a -> Right a diff --git a/Util/EventBase.hs b/Util/EventBase.hs new file mode 100644 --- /dev/null +++ b/Util/EventBase.hs @@ -0,0 +1,90 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.EventBase + ( CppIOExecutor + , EventBase(..) + , EventBaseDataplane(..) + , EventBaseProvider(..) + , EventBaseDataplaneProvider(..) + , withEventBaseDataplane + , initExecutor + , destroyExecutor + ) where + +import Control.Exception +import Foreign.Ptr +import Util.Executor + +-- +-- Makes an IOExecutor and makes it available in Haskell. +-- + +-- +-- export +-- + +newtype EventBase = EventBase (Ptr CppEventBase) + +class EventBaseProvider a where + getEventBase :: a -> IO EventBase + +newtype EventBaseDataplane = EventBaseDataplane (Ptr CppIOExecutor) + +class EventBaseProvider a => EventBaseDataplaneProvider a where + getEventBaseDataplane :: a -> IO EventBaseDataplane + +instance EventBaseProvider EventBaseDataplane where + getEventBase (EventBaseDataplane ptr) = + EventBase <$> c_getIOExecutorEventBase ptr + +instance EventBaseDataplaneProvider EventBaseDataplane where + getEventBaseDataplane = return + +instance ExecutorProvider EventBase where + -- event bases are executors + getExecutor (EventBase p) = Executor <$> c_castEventBaseToExecutor p + +instance ExecutorProvider EventBaseDataplane where + -- io executors are executors + getExecutor (EventBaseDataplane p) = Executor <$> c_castIOExecutorToExecutor p + +withEventBaseDataplane + :: (EventBaseDataplane -> IO b) + -> IO b +withEventBaseDataplane = bracket initExecutor destroyExecutor + +initExecutor :: IO EventBaseDataplane +initExecutor = EventBaseDataplane <$> c_newExecutor + +destroyExecutor :: EventBaseDataplane -> IO () +destroyExecutor (EventBaseDataplane ptr) = c_destroyExecutor ptr + +-- +-- foreign +-- + +data CppEventBase +data CppIOExecutor + +foreign import ccall unsafe "common_hs_eventbase_newExecutor" + c_newExecutor :: IO (Ptr CppIOExecutor) + +foreign import ccall unsafe "common_hs_eventbase_destroyExecutor" + c_destroyExecutor :: Ptr CppIOExecutor -> IO () + +foreign import ccall unsafe "common_hs_eventbase_getIOExecutorEventBase" + c_getIOExecutorEventBase :: Ptr CppIOExecutor -> IO (Ptr CppEventBase) + +-- we cannot just use Haskell `castPtr` as there is virtual inheritance involved + +foreign import ccall unsafe "common_hs_eventbase_castIOExecutorToExecutor" + c_castIOExecutorToExecutor :: Ptr CppIOExecutor -> IO (Ptr CppFollyExecutor) + +foreign import ccall unsafe "common_hs_eventbase_castEventBaseToExecutor" + c_castEventBaseToExecutor :: Ptr CppEventBase -> IO (Ptr CppFollyExecutor) diff --git a/Util/Executor.hs b/Util/Executor.hs new file mode 100644 --- /dev/null +++ b/Util/Executor.hs @@ -0,0 +1,57 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Executor + ( CppFollyExecutor + , Executor(..) + , ExecutorKeepAlive(..) + , ExecutorProvider(..) + , getGlobalCPUExecutor + , releaseGlobalCPUExecutor + , withGlobalCPUExecutor + ) where + +import Foreign.Ptr +import Control.Exception (bracket) + +-- CppExecutor is a folly::Executor* +data CppFollyExecutor +newtype Executor = Executor (Ptr CppFollyExecutor) + +data CppFollyExecutorKeepAlive +newtype ExecutorKeepAlive = ExecutorKeepAlive (Ptr CppFollyExecutorKeepAlive) + +class ExecutorProvider a where + getExecutor :: a -> IO Executor + +instance ExecutorProvider Executor where + getExecutor = return + +instance ExecutorProvider ExecutorKeepAlive where + getExecutor (ExecutorKeepAlive p) = Executor <$> c_getExecutorFromKeepAlive p + +getGlobalCPUExecutor :: IO ExecutorKeepAlive +getGlobalCPUExecutor = ExecutorKeepAlive <$> c_getGlobalCPUExecutor + +releaseGlobalCPUExecutor :: ExecutorKeepAlive -> IO () +releaseGlobalCPUExecutor (ExecutorKeepAlive p) = c_releaseGlobalCPUExecutor p + +withGlobalCPUExecutor + :: (ExecutorKeepAlive -> IO b) + -> IO b +withGlobalCPUExecutor = bracket getGlobalCPUExecutor releaseGlobalCPUExecutor + +foreign import ccall unsafe "common_hs_getGlobalCPUExecutor" + c_getGlobalCPUExecutor :: IO (Ptr CppFollyExecutorKeepAlive) + +foreign import ccall unsafe "common_hs_releaseGlobalCPUExecutor" + c_releaseGlobalCPUExecutor :: Ptr CppFollyExecutorKeepAlive -> IO () + +foreign import ccall unsafe "common_hs_getExecutorFromKeepAlive" + c_getExecutorFromKeepAlive + :: Ptr CppFollyExecutorKeepAlive -> IO (Ptr CppFollyExecutor) diff --git a/Util/FFI.hs b/Util/FFI.hs new file mode 100644 --- /dev/null +++ b/Util/FFI.hs @@ -0,0 +1,156 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-star-is-type #-} +module Util.FFI ( + FFIError, ffiErrorMessage, call, + List(..), FFIFun(..), Tuple(..), invoke, + + unsafeWithForeignPtr, +) where + +import Foreign hiding (with, withMany) +import Foreign.C +#if __GLASGOW_HASKELL__ >= 902 +import GHC.ForeignPtr +#endif +import System.IO.Unsafe (unsafePerformIO) +import Control.Exception +import Control.Monad + +#if __GLASGOW_HASKELL__ < 902 +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +unsafeWithForeignPtr = withForeignPtr +#endif + +foreign import ccall unsafe "&hs_ffi_free_error" hs_ffi_free_error + :: FunPtr (CString -> IO ()) + +newtype FFIError = FFIError (ForeignPtr CChar) + +ffiErrorMessage :: FFIError -> String +ffiErrorMessage (FFIError fp) = + unsafePerformIO $ unsafeWithForeignPtr fp peekCString + +instance Show FFIError where + show = ffiErrorMessage + +instance Exception FFIError + +-- | Call an FFI function that returns 'nullPtr' if it succeeds, or a +-- 'CString' containing the error message if it fails. On failure the +-- error is thrown as an 'FFIError' exception. +{-# INLINE call #-} +call :: IO CString -> IO () +call f = do + p <- f + when (p /= nullPtr) $ callError p + +callError :: CString -> IO () +callError p = do + fp <- newForeignPtr hs_ffi_free_error p + throwIO $ FFIError fp + +infixr 5 :> + +data List xs where + Nil :: List '[] + (:>) :: x -> List xs -> List (x ': xs) + +class Tuple xs where + type Tup xs + tuple :: List xs -> Tup xs + +instance Tuple '[] where + type Tup '[] = () + tuple Nil = () + +instance Tuple '[a] where + type Tup '[a] = a + tuple (a :> _) = a + +instance Tuple [a,b] where + type Tup [a,b] = (a,b) + tuple (a :> b :> _) = (a,b) + +instance Tuple [a,b,c] where + type Tup [a,b,c] = (a,b,c) + tuple (a :> b :> c :> _) = (a,b,c) + +instance Tuple [a,b,c,d] where + type Tup [a,b,c,d] = (a,b,c,d) + tuple (a :> b :> c :> d :> _) = (a,b,c,d) + +instance Tuple [a,b,c,d,e] where + type Tup [a,b,c,d,e] = (a,b,c,d,e) + tuple (a :> b :> c :> d :> e :> _) = (a,b,c,d,e) + +instance Tuple [a,b,c,d,e,f] where + type Tup [a,b,c,d,e,f] = (a,b,c,d,e,f) + tuple (a :> b :> c :> d :> e :> f :> _) = (a,b,c,d,e,f) + +instance Tuple [a,b,c,d,e,f,g] where + type Tup [a,b,c,d,e,f,g] = (a,b,c,d,e,f,g) + tuple (a :> b :> c :> d :> e :> f :> g :> _) = (a,b,c,d,e,f,g) + +instance Tuple [a,b,c,d,e,f,g,h] where + type Tup [a,b,c,d,e,f,g,h] = (a,b,c,d,e,f,g,h) + tuple (a :> b :> c :> d :> e :> f :> g :> h :> _) = (a,b,c,d,e,f,g,h) + +instance Tuple [a,b,c,d,e,f,g,h,i] where + type Tup [a,b,c,d,e,f,g,h,i] = (a,b,c,d,e,f,g,h,i) + tuple (a :> b :> c :> d :> e :> f :> g :> h :> i :> _) = (a,b,c,d,e,f,g,h,i) + +class FFIFun f where + type Res f :: [*] + invoke' :: f -> IO (List (Res f)) + +instance FFIFun (IO CString) where + type Res (IO CString) = '[] + invoke' f = do + call f + return Nil + +instance FFIFun (IO ()) where + type Res (IO ()) = '[] + invoke' f = do + f + return Nil + +-- | For output parameter 'Ptr a' this will 'alloca' memory (unitialized) +-- and then proceed to the next parameter. On returning this prepends +-- the result into x. This is only safe if the invoked function +-- always fills in this output parameter pointer before returning. +instance (Storable a, FFIFun f) => FFIFun (Ptr a -> f) where + type Res (Ptr a -> f) = a ': Res f + invoke' f = alloca $ \p -> do + xs <- invoke' (f p) + x <- peek p + return $ x :> xs + +-- | Call an FFI function with automatic handling of return values and +-- errors. +-- +-- For example, if we have a function with one input and two outputs, +-- optionally returning an error as a `CString`: +-- +-- > foreign import ccall unsafe json_encode +-- > :: Ptr Dyn -> Ptr (Ptr Word8) -> Ptr CSize -> IO CString +-- +-- Then we can call it like this: +-- +-- > (bytes, size) <- invoke $ json_encode dyn +-- +-- where @bytes :: Ptr Word8@ and @size :: CSize@. +-- +-- Note: this is only safe if the invoked function always fills in +-- output parameter pointers before returning. +invoke :: (FFIFun f, Tuple (Res f)) => f -> IO (Tup (Res f)) +invoke = fmap tuple . invoke' diff --git a/Util/Fd.hs b/Util/Fd.hs new file mode 100644 --- /dev/null +++ b/Util/Fd.hs @@ -0,0 +1,46 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Fd + ( withFdEventNotification + ) where + +import Control.Exception +import Control.Monad +import GHC.Event hiding (closeFd) +import Foreign.C +import System.Posix.IO +import System.Posix.Types + +-- | Uses a file descriptor and GHC's event manager to run a callback +-- once the file descriptor is written to. Is less expensive than a new FFI +-- call from C++ back into Haskell. +withFdEventNotification + :: Exception e + => e -- ^ Exception to throw when unable to get the event manager + -> IO () -- ^ The callback to run on fd write + -> Lifetime -- ^ OneShot or MultiShot + -> (Fd -> IO a) -- ^ Action to run with the file descriptor to write to + -> IO a +withFdEventNotification err callback lifetime action = do + evm <- maybe (throw err) return =<< getSystemEventManager + withEventFd $ \fd -> + bracket (registerFd evm cb fd evtRead lifetime) (unregisterFd evm) $ + const $ action fd + where + cb _ _ = callback + +withEventFd :: (Fd -> IO a) -> IO a +withEventFd = bracket + (do fd <- c_eventfd 0 0 + when (fd == -1) $ throwErrno "eventFd" + return $ Fd fd) + closeFd + +foreign import ccall unsafe "eventfd" + c_eventfd :: CInt -> CInt -> IO CInt diff --git a/Util/FilePath.hs b/Util/FilePath.hs new file mode 100644 --- /dev/null +++ b/Util/FilePath.hs @@ -0,0 +1,68 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.FilePath + ( DirEnv(..) + , getDirEnv + , absolutise + , absolutiseWith + , mnameToPath + , pathToMName + ) where + +import Data.Char (isAsciiUpper) +import Data.Text (Text) +import Data.Text as Text (pack, unpack) + +import System.Directory +import System.FilePath + +data DirEnv = DirEnv + { homeDir :: FilePath + , currentDir :: FilePath + } + +getDirEnv :: IO DirEnv +getDirEnv = DirEnv <$> getHomeDirectory <*> getCurrentDirectory + +-- | Makes a path absolute, handling home directories +absolutiseWith :: DirEnv -> FilePath -> FilePath +absolutiseWith DirEnv{..} "~" = homeDir +absolutiseWith DirEnv{..} ('~':'/':p) = normalise $ homeDir p +absolutiseWith DirEnv{..} p | isRelative p = normalise $ currentDir p +absolutiseWith _ p = p + +-- | Get the absolute FilePath based on the directory env +-- +-- >>> absolutise "~/si_sigma/A.hs" +-- "{HOME_DIR}/si_sigma/A.hs" +-- >>> absolutise "sigma/repo/Foo/Bar/Baz.hs" +-- "{CURRENT_DIR}/sigma/repo/Foo/Bar/Baz.hs" +absolutise :: FilePath -> IO FilePath +absolutise p = absolutiseWith <$> getDirEnv <*> pure p + +-- | Given a FilePath to a module, returns the expected module name +-- +-- >>> pathToMName "sigma/repo/Foo/Bar/Baz.hs" +-- "Foo.Bar.Baz" +pathToMName :: FilePath -> Text +pathToMName = Text.pack . map convSeparator . getModulePath . dropExtension + where + convSeparator c = if isPathSeparator c then '.' else c + getModulePath = joinPath . filterModulePaths . splitPath + filterModulePaths = reverse . takeWhile isModulePath . reverse + isModulePath (c:_) = isAsciiUpper c + isModulePath _ = False + +-- | Given a module name, returns the FilePath +-- +-- >>> mnameToPath "Foo.Bar.Baz" +-- "Foo/Bar/Baz.hs" +mnameToPath :: Text -> FilePath +mnameToPath = + (<> ".hs") . map (\c -> if c == '.' then pathSeparator else c) . Text.unpack diff --git a/Util/Function.hs b/Util/Function.hs new file mode 100644 --- /dev/null +++ b/Util/Function.hs @@ -0,0 +1,15 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Function + ( compose + ) where + +-- | Composes a list of endofunctions. +compose :: [a -> a] -> a -> a +compose = foldr (.) id diff --git a/Util/Graph.hs b/Util/Graph.hs new file mode 100644 --- /dev/null +++ b/Util/Graph.hs @@ -0,0 +1,42 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Graph + ( postorder + ) where + +import Data.Hashable +import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap + +-- | Post-order traversal of a graph: guarantees that the dependents +-- of a node occur before it in the result list, while as far as +-- possible retaining the original order of the nodes. +postorder + :: (Hashable vertex, Eq vertex) + => [node] + -- ^ Nodes in the order of traversal + -> (node -> vertex) + -- ^ Extract a hashable vertex from the node + -> (node -> [vertex]) + -- ^ Out-edges from a node. Vertices that aren't in the set of + -- nodes are ignored. + -> [node] + -- ^ Result of post-order traversal +postorder nodes vert out = go HashSet.empty nodes (\_ -> []) + where + m = HashMap.fromList [ (vert n, n) | n <- nodes ] + + go seen [] cont = cont seen + go seen (n : nodes) cont + | v `HashSet.member` seen = go seen nodes cont + | otherwise = go (HashSet.insert v seen) deps + (\seen -> n : go seen nodes cont) + where + v = vert n + deps = [ n | v <- out n, Just n <- [HashMap.lookup v m] ] diff --git a/Util/HSE.hs b/Util/HSE.hs new file mode 100644 --- /dev/null +++ b/Util/HSE.hs @@ -0,0 +1,24 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} + +module Util.HSE + ( + classA + ) where + +import Language.Haskell.Exts.Syntax hiding (Type) +import qualified Language.Haskell.Exts.Syntax as HS + +classA :: l -> QName l -> [HS.Type l] -> Asst l +#if MIN_VERSION_haskell_src_exts(1,22,0) +classA l conName args = TypeA l (foldl (TyApp l) (TyCon l conName) args) +#else +classA = ClassA +#endif diff --git a/Util/HUnit.hs b/Util/HUnit.hs new file mode 100644 --- /dev/null +++ b/Util/HUnit.hs @@ -0,0 +1,107 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.HUnit + ( absError + , assertAbsError + , assertElem + , assertSubsetOf + , assertNotElem + , assertPermutationOf + , assertThrow + ) where + +import Control.Exception +import Data.Either (isLeft) +import Data.Foldable (toList) +import Data.List +import Test.HUnit + + +-- | The absolute error between an expected and actual value. +absError :: (Fractional a) => a -> a -> a +absError expected actual = abs (expected - actual) + +-- | Asserts that the absolute error of a value is within a given +-- range. If you want the range to be in the realm of machine epsilon, +-- use @Data.AEq@ instead. +assertAbsError + :: (Fractional a, Ord a, Show a) + => String + -- ^ Error message. + -> a + -- ^ Expected value. + -> a + -- ^ Error range (e.g., @1e-3@). + -> a + -- ^ Actual value. + -> Assertion +assertAbsError message expected epsilon actual + = flip assertBool (absError expected actual <= epsilon) $ concat + [ message + , " (expected " + , show expected + , "+/-" + , show epsilon + , " but got " + , show actual + , ")" + ] + +assertPermutationOf + :: (Ord a, Show a) + => String -> [a] -> [a] -> Assertion +assertPermutationOf m as bs = assertEqual m (sort as) (sort bs) + +assertElem :: (Eq a, Show a, Foldable t) => String -> a -> t a -> Assertion +assertElem message expected actual = + flip assertBool (expected `elem` actual) $ concat + [ message + , " (expected " + , show expected + , " to occur in " + , show $ toList actual + , ")" + ] + +assertSubsetOf + :: (Eq a, Show a, Foldable t, Foldable f) + => String + -> f a + -> t a + -> Assertion +assertSubsetOf message expected actual = + flip assertBool (all (`elem` actual) expected) $ concat + [ message + , " (expected all of" + , show $ toList expected + , " to occur in " + , show $ toList actual + , ")" + ] + +assertNotElem :: (Eq a, Show a, Foldable t) => String -> a -> t a -> Assertion +assertNotElem message expected actual = + flip assertBool (not $ expected `elem` actual) $ concat + [ message + , " (expected " + , show expected + , " to not occur in " + , show $ toList actual + , ")" + ] + +assertThrow :: (Show a) => String -> IO a -> Assertion +assertThrow message test = do + (actual :: Either SomeException a) <- try test + flip assertBool (isLeft actual) $ concat + [ message + , " (expected: exception thrown; but got: " + , show actual + , ")" + ] diff --git a/Util/HashMap/Strict.hs b/Util/HashMap/Strict.hs new file mode 100644 --- /dev/null +++ b/Util/HashMap/Strict.hs @@ -0,0 +1,21 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.HashMap.Strict + ( mapKeys + ) where + +import Control.Arrow (first) +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap + +-- | Transform a HashMap by applying a function to every key. +mapKeys :: (Eq b, Hashable b) => (a -> b) -> HashMap a v -> HashMap b v +mapKeys mapper = + HashMap.fromList . map (first mapper) . HashMap.toList diff --git a/Util/IO.hs b/Util/IO.hs new file mode 100644 --- /dev/null +++ b/Util/IO.hs @@ -0,0 +1,438 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.IO + ( atomicIO + , die + , readFileUTF8 + , writeFileUTF8 + , writeFileAtomicUTF8 + , readJSON + , eitherReadJSON + , writeJSON + , writeJSON' + , removeIfExists + , readFileIfExists + , writeFileIfChanged + , writeFileAtomically + , writeTextIfChanged + , loudlyWriteTextIfChanged + , writeTextIfChangedWith + , writeUtf8StringIfChanged + , loudlyWriteUtf8StringIfChanged + , writeUtf8StringIfChangedWith + , Verbosity(..) + , writeFileUTF8Text + , readFileUTF8Text + , getDevserverUser + , getDevserverHostInfo + , getHostInfo + , getHostname + , getUserForProcess + , getGroupForProcess + , getUsername + , getUserUnixname + , HostInfo(..) + , copyDirectoryContents + , copyDirectoryContents_ + , listDirectoryRecursive + , saveStdout + , saveStderr + , slowIO + , isModifiedAfter + , safeRemovePathForcibly + , withLazy + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception as Exception +import Control.Monad +import Control.Monad.Extra +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.Foldable +import Data.List +import Data.List.Split +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO +import GHC.IO.Handle +import System.Directory +import System.Exit hiding (die) +import System.FilePath +import System.IO +import System.IO.Error +import System.IO.Unsafe +import System.Posix.User +import System.Process +import System.Environment +import Text.Printf +import Util.String (strip) +import qualified Data.ByteString.Lazy as B + +-- | Performs some IO atomically. This is presumed to be only used +-- to avoid output interleaving where verbose information is printed +-- concurrently. +atomicIO :: IO a -> IO a +atomicIO = withMVar atomicIOLock . const + +{-# NOINLINE atomicIOLock #-} +atomicIOLock :: MVar () +atomicIOLock = unsafePerformIO $ newMVar () + +-- | Exit immediately with 'exitCode', showing a message on 'stderr'. +die :: Int -> String -> IO a +die exitCode msg = + hPutStrLn stderr msg >> exitWith (ExitFailure exitCode) + +-- | Compare a file's content against some benchmark content to see +-- whether it's changed. You really want to pass in some kind of lazy +-- read function here so that (in-)equality can be determined as soon +-- as possible during the file read. Note that if the file doesn't +-- exist, then we return True, that is, we state that the file has +-- changed. +hasFileContentChanged :: + (Eq a) => (FilePath -> IO a) -> FilePath -> a -> IO Bool +hasFileContentChanged read filePath benchmarkContent = + catchIOError + (liftM (/= benchmarkContent) $ read filePath) + (\_ -> return True) + +-- | Writes a file only if it differs from the content that would be +-- written. +writeFileIfChanged :: (Eq a) => + (FilePath -> IO a) -> (Handle -> a -> IO ()) -> FilePath -> a -> IO () +writeFileIfChanged read hWrite targetPath content = do + different <- hasFileContentChanged read targetPath content + when different $ writeFileAtomically hWrite targetPath content + +-- | Write a file "atomically" by writing it fully to a temp +-- directory, then copying it to its final location. +writeFileAtomically :: (Handle -> a -> IO ()) -> FilePath -> a -> IO () +writeFileAtomically hWrite targetPath content = + Exception.bracketOnError mkTempFile rmTempFile commit + where + (targetDir, targetFile) = splitFileName targetPath + mkTempFile = openTempFile targetDir (targetFile <.> "tmp") + rmTempFile (tmpPath, handle) = hClose handle >> removeFile tmpPath + commit (tmpPath, handle) = do + hWrite handle content + hClose handle + renameFile tmpPath targetPath + +-- | Remove file if it exists. Returns True if the file existed. +removeIfExists :: FilePath -> IO Bool +removeIfExists filePath = + (removeFile filePath >> return True) `catch` \e -> + if isDoesNotExistError e + then return False + else throwIO e + +readFileIfExists :: FilePath -> IO (Maybe String) +readFileIfExists filePath = + (Just <$> readFile filePath) `catch` \e -> + if isDoesNotExistError e + then return Nothing + else throwIO e + +-- | Read a FromJSON datatype from a file containing a JSON string. +readJSON :: FromJSON a => FilePath -> IO a +readJSON f = do + json <- B.readFile f + case eitherDecode json of + Left err -> error $ printf "Failed parsing JSON file %s: %s\n" f err + Right v -> return v + +eitherReadJSON :: FromJSON a => FilePath -> IO (Either String a) +eitherReadJSON f = (eitherDecode <$> B.readFile f) + `catch` (\(e :: Exception.IOException) -> return $ Left (show e)) + +-- | Write a ToJSON datatype to a file as pretty-printed JSON. +writeJSON :: ToJSON a => FilePath -> a -> IO () +writeJSON path = B.writeFile path . encodePretty + +-- | Write a ToJSON datatype to a file as pretty-printed JSON. +-- Adds a newline at the end of the file +writeJSON' :: ToJSON a => Config -> FilePath -> a -> IO () +writeJSON' config path obj = B.writeFile path (encodePretty' config obj <> "\n") + +-- | Read a UTF-8 encoded file. Like 'readFile' but forces the +-- encoding to UTF-8. +readFileUTF8 :: FilePath -> IO String +readFileUTF8 path = do + h <- openFile path ReadMode + hSetEncoding h utf8 + hGetContents h + +-- | Write a UTF-8 encoded file. Like 'writeFile' but forces the +-- encoding to UTF-8. +writeFileUTF8 :: Handle -> String -> IO () +writeFileUTF8 h str = do + hSetEncoding h utf8 + hPutStr h str + +-- | Write a UTF-8 encoded file atomically. Writes to a temporary file +-- first, and then atomically moves the temporary file to the destination +-- if successful. +-- +-- Adapted from Distribution.Simple.Utils.writeFileAtomic in Cabal. +writeFileAtomicUTF8 :: FilePath -> String -> IO () +writeFileAtomicUTF8 targetPath content = do + let (targetDir, targetFile) = splitFileName targetPath + Exception.bracketOnError + (do + createDirectoryIfMissing True targetDir + openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") + (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (\(tmpPath, handle) -> do + hSetEncoding handle utf8 + hPutStr handle content + hClose handle + renameFile tmpPath targetPath) + +-- | Write a UTF-8 encoded file from text, only if it differs from the content +-- that would be written. If the output directory will be created if it does +-- not exist. +writeTextIfChanged :: FilePath -> Text -> IO () +writeTextIfChanged path text = do + createDirectoryIfMissing True $ takeDirectory path + writeFileIfChanged readFileUTF8Text writeFileUTF8Text path text + +-- Like Util.IO.writeTextIfChanged, but announce upon success. +loudlyWriteTextIfChanged :: FilePath -> Text -> IO () +loudlyWriteTextIfChanged = writeTextIfChangedWith Loud putStrLn + +data Verbosity = Loud | Quiet + +writeTextIfChangedWith + :: Verbosity + -> (String -> IO ()) + -> FilePath + -> Text + -> IO () +writeTextIfChangedWith verbosity f path text = do + createDirectoryIfMissing True $ takeDirectory path + writeFileIfChanged readFileUTF8Text writeFileUTF8Text_ path text + where + writeFileUTF8Text_ h txt = do + writeFileUTF8Text h txt + case verbosity of + Loud -> atomicIO $ f ("Written " ++ path) + Quiet -> return () + +-- | Write a UTF-8 encoded file from text. Like 'writeFile' but forces the +-- encoding to UTF-8. +writeFileUTF8Text :: Handle -> Text -> IO () +writeFileUTF8Text h text = do + hSetEncoding h utf8 + TextIO.hPutStr h text + +-- | Read a UTF-8 encoded file as text. +readFileUTF8Text :: FilePath -> IO Text +readFileUTF8Text path = do + h <- openFile path ReadMode + hSetEncoding h utf8 + TextIO.hGetContents h + +-- Like Util.IO.writeTextIfChanged, but works for String +writeUtf8StringIfChanged :: FilePath -> String -> IO () +writeUtf8StringIfChanged path content = do + createDirectoryIfMissing True $ takeDirectory path + writeFileIfChanged readFileUTF8 writeFileUTF8 path content + +-- Like Util.IO.loudlyWriteTextIfChanged, but works for String. +loudlyWriteUtf8StringIfChanged :: FilePath -> String -> IO () +loudlyWriteUtf8StringIfChanged = writeUtf8StringIfChangedWith Loud putStrLn + +-- Like Util.IO.writeTextIfChangedWith, but works for String +writeUtf8StringIfChangedWith + :: Verbosity + -> (String -> IO ()) + -> FilePath + -> String + -> IO () +writeUtf8StringIfChangedWith verbosity f path content = do + createDirectoryIfMissing True $ takeDirectory path + writeFileIfChanged readFileUTF8 writeFileUTF8_ path content + where + writeFileUTF8_ h txt = do + writeFileUTF8 h txt + case verbosity of + Loud -> atomicIO $ f ("Written " ++ path) + Quiet -> return () + +getUserForProcess :: IO String +getUserForProcess = fmap userName $ getUserEntryForID =<< getRealUserID + +getGroupForProcess :: IO String +getGroupForProcess = fmap groupName $ getGroupEntryForID =<< getRealGroupID + +data HostInfo = HostInfo + { hostname :: Text + , username :: Text + } + +getHostInfo :: IO HostInfo +getHostInfo = do + user <- Text.pack <$> getUsername + host <- Text.pack <$> getHostname + return $ HostInfo host user + +getDevserverHostInfo :: IO HostInfo +getDevserverHostInfo = do + user <- Text.pack <$> getDevserverUser + host <- Text.pack <$> getHostname + return $ HostInfo host user + +-- | Equivalent of get_devserver_username in www (see +-- https://fburl.com/codex/05mqipn2). +getDevserverUser :: IO String +getDevserverUser = getUserForProcess + +-- | Get username using 'id' command line tool +getUsername :: IO String +getUsername = init <$> readProcess "id" ["-un"] "" + +-- | Get hostname using 'hostname' command line tool +getHostname :: IO String +getHostname = strip <$> readProcess "hostname" [] [] + +-- Try to get a meaninful user unix name. This will not realize that the user +-- was changed to a non-root account like mysql. +getUserUnixname :: IO String +getUserUnixname = do + user <- getUserForProcess + fromMaybe user <$> asum + [ return $ helpful $ Just user + , helpful <$> getTupperwareUser + , helpful <$> getDevserverOwner + ] + where + unhelpfulNames = ["root", "twsvcscm", "svcscm", "apache"] + + helpful (Just name) | name `elem` unhelpfulNames = Nothing + helpful mname = mname + + getTupperwareUser = lookupEnv "TW_JOB_USER" + +getDevserverOwner :: IO (Maybe String) +getDevserverOwner = do + res <- Exception.try $ readFile "/etc/devserver.owners" + :: IO (Either Exception.SomeException String) + return $ case lines <$> res of + Right (name:_) -> Just name + _ -> Nothing + +redirectHandle :: Handle -> FilePath -> IO () -> IO () +redirectHandle handle file io = + withFile file WriteMode $ \fh -> do + bracket (hDuplicate handle) (`hDuplicateTo` handle) $ \_ -> do + hDuplicateTo fh handle + io + +-- | Run an IO action saving the stderr to a file +saveStderr :: FilePath -> IO () -> IO () +saveStderr = redirectHandle stderr + +-- | Run an IO action saving the stdout to a file +saveStdout :: FilePath -> IO () -> IO () +saveStdout = redirectHandle stdout + +-- | Copy all the contents of one directory to another directory +-- and return all the resulting paths. +-- This will create the target directory if it does not exist. + +-- | DISCLAIMER: This is not an atomic operation. +copyDirectoryContents :: FilePath -> FilePath -> IO [FilePath] +copyDirectoryContents dirfrom dirto = do + paths <- listDirectoryRecursive dirfrom + forM paths $ \path -> do + let relfile = makeRelative dirfrom path + let frompath = dirfrom relfile + let topath = dirto relfile + createDirectoryIfMissing True $ takeDirectory topath + copyFile frompath topath + return topath + +copyDirectoryContents_ :: FilePath -> FilePath -> IO () +copyDirectoryContents_ dirfrom dirto + = void $ copyDirectoryContents dirfrom dirto + +listDirectoryRecursive + :: FilePath + -> IO [FilePath] +listDirectoryRecursive dir = do + fs <- listDirectory dir + (concat <$>) $ forM fs $ \file -> do + let f = dir file + isFile <- doesFileExist f + if isFile + then return [f] + else do + isDir <- doesDirectoryExist f + if isDir + then listDirectoryRecursive f + else return [] + + +-- | Perform IO in batches with delays between them. Useful to avoid +-- filling up fixed size queues. +slowIO + :: ([a] -> IO ()) -- ^ operation to apply to each batch + -> [a] -- ^ all arguments + -> Int -- ^ maximum batch size + -> Int -- ^ delay, in milliseconds + -> IO () +slowIO f args batchSize delay = + sequence_ + $ intersperse (threadDelay (delay*1000)) + $ map f + $ chunksOf batchSize args + +isModifiedAfter :: FilePath -> FilePath -> IO Bool +isModifiedAfter fp1 fp2 = ifM (doesFileExist fp1 &&^ doesFileExist fp2) + (do + time <- getModificationTime fp1 + time' <- getModificationTime fp2 + return $ time > time') + (return False) + +-- | System.Posix.removeLink calls @unlink()@ with an unsafe FFI call, +-- which can cause long stalls in some cases. This affects things +-- defined in terms of it, including 'System.Directory.removeFile', +-- and 'System.Directory.removePathForcibly' to name a couple. +-- +-- This function is a replacement for 'removePathForcibly' that forks +-- an external 'rm' instead. +safeRemovePathForcibly :: FilePath -> IO () +safeRemovePathForcibly path = callProcess "rm" [ "-rf", path ] + +-- | Turn a with-style resource scoping function into one that +-- executes lazily. The @with@ is performed the first time the +-- supplied getter is invoked, and is released when @withLazy@ +-- returns. +withLazy + :: (forall b . (a -> IO b) -> IO b) + -- ^ with-style function to allocate a scoped resource of type @a@ + -> (IO a -> IO c) + -- ^ provides a lazy getter for the resource @a@ + -> IO c +withLazy wit fn = do + barrier <- newEmptyMVar + result <- newEmptyMVar + done <- newEmptyMVar + let + get = do _ <- tryPutMVar barrier (); readMVar result + go = do + takeMVar barrier + wit $ \a -> do + putMVar result a + takeMVar done + snd <$> concurrently go (fn get `finally` putMVar done ()) diff --git a/Util/IOBuf.hsc b/Util/IOBuf.hsc new file mode 100644 --- /dev/null +++ b/Util/IOBuf.hsc @@ -0,0 +1,101 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.IOBuf + ( unsafeWithIOBuf + , IOBuf + , toLazy + ) where + +import Control.Exception (mask_) +import Data.ByteString.Internal +import Data.ByteString.Unsafe +import Data.Word +import Foreign.C +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.Storable +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString as Strict + +#include + +-- | This is the representation of a C++ HS_IOBuf. It has no representation in +-- Haskell therefore we use an uninhabited type +data IOBuf + +-- We need a Storable instance in order to alloca an HS_IOBuf from haskell +instance Storable IOBuf where + sizeOf _ = (#size HS_IOBuf) + alignment _ = alignment (undefined :: Ptr ()) + -- IOBuf is an uninhabited type, so peek and poke are not implemented + peek = error "peek: unimplemented" + poke = error "poke: unimplemented" + +-- | Marshal a lazy ByteString to a C++ HS_IOBuf and call a function on the +-- result. This is unsafe because it uses the underlying bytestring buffers of +-- the Haskell ByteString in C++. If this gets garbage collected while it is +-- still being used in C++, then the program will crash. +unsafeWithIOBuf :: Lazy.ByteString -> (Ptr IOBuf -> IO a) -> IO a +unsafeWithIOBuf bs f = + withChain (Lazy.toChunks bs) $ \str_arr len_arr len -> + alloca $ \hs_iobuf -> do + (#poke HS_IOBuf, str_arr) hs_iobuf str_arr + (#poke HS_IOBuf, len_arr) hs_iobuf len_arr + (#poke HS_IOBuf, len) hs_iobuf len + f hs_iobuf + +withChain + :: [ByteString] + -> (Ptr CString -> Ptr CSize -> CSize -> IO a) + -> IO a +withChain chunks f = withMany unsafeUseAsCStringLen chunks $ \cstrs -> + let + (strs, lens) = unzip cstrs + in + withArrayLen strs $ \len strings -> + withArray (map fromIntegral lens) $ \lengths -> + f strings lengths (fromIntegral len) + +data CIOBufData + +-- The ForeignPtr points to the data buffer, not the IOBuf, but +-- the finalizer calls the destructor on the IOBuf*. +-- This function takes ownership of Ptr IOBuf. +toByteString :: Ptr IOBuf -> Int -> Ptr Word8 -> IO Strict.ByteString +toByteString p p_len p_buf = mask_ $ do + fp <- newForeignPtrEnv c_destroy p p_buf + return $ fromForeignPtr fp 0 p_len + +-- | A mock fmap over the IOBuf chain to create strict ByteStrings. +bufToChunks + :: Ptr IOBuf + -> IO [Strict.ByteString] +bufToChunks ptr + | ptr == nullPtr = pure [] + | otherwise = allocaBytes #{size IOBufData} $ \p_data -> do + c_get_data ptr p_data + p_len <- #{peek IOBufData, length_} p_data + p_buf <- #{peek IOBufData, data_buf_} p_data + p_next <- #{peek IOBufData, next_} p_data + (:) <$> toByteString ptr p_len p_buf + <*> bufToChunks p_next + +-- | Marshall a folly::IOBuf to a lazy ByteString. Could also fold and append +-- to a lazy ByteString instead of using fromChunks. +toLazy :: Ptr IOBuf -> IO Lazy.ByteString +toLazy p = Lazy.fromChunks <$> + (mask_ $ bufToChunks p) + +foreign import ccall unsafe "get_iobuf_data" c_get_data + :: Ptr IOBuf -> Ptr CIOBufData -> IO () +foreign import ccall unsafe "&destroy_iobuf" c_destroy + :: FinalizerEnvPtr IOBuf Word8 diff --git a/Util/JSON/Pretty.hs b/Util/JSON/Pretty.hs new file mode 100644 --- /dev/null +++ b/Util/JSON/Pretty.hs @@ -0,0 +1,66 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS -Wno-orphans #-} + +-- | Display JSON values using pretty printing combinators. +-- +-- Adapted from Text.Pretty.JSON in the json package, which is +-- Copyright (c) Galois, Inc. 2007 +-- +-- Why would you use this instead of Aeson + aeson-pretty? +-- 1. You want to retain the ordering of fields in JSON objects. Aeson +-- doesn't do this. +-- 2. The pretty-printer here produces more compact output than aeson-pretty. + +module Util.JSON.Pretty + ( -- instance Pretty JSValue + ) where + +import Data.Ratio +import Data.Char +import Numeric +import Text.JSON + +import Compat.Prettyprinter + +instance Pretty JSValue where + pretty v = case v of + JSNull -> "null" + JSBool True -> "true" + JSBool False -> "false" + JSRational asf x -> pp_number asf x + JSString x -> pp_string (fromJSString x) + JSArray vs -> pp_array vs + JSObject xs -> pp_object (fromJSObject xs) + +pp_number :: Bool -> Rational -> Doc a +pp_number _ x | denominator x == 1 = pretty (numerator x) +pp_number True x = pretty (fromRational x :: Float) +pp_number _ x = pretty (fromRational x :: Double) + +pp_array :: [JSValue] -> Doc a +pp_array xs = sep [nest 2 (vsep ("[" : punctuate comma (map pretty xs))), "]"] + +pp_object :: [(String,JSValue)] -> Doc a +pp_object xs = + sep [nest 2 (vsep ("{" : punctuate comma (map pp_field xs))), "}"] + where pp_field (k,v) = pp_string k <> colon <+> pretty v + +pp_string :: String -> Doc a +pp_string x = dquotes $ hcat $ map pp_char x + where pp_char '\\' = "\\\\" + pp_char '"' = "\\\"" + pp_char c | isControl c = uni_esc c + pp_char c = pretty [c] + + uni_esc c = "\\u" <> pretty (pad 4 (showHex (fromEnum c) "")) + + pad n cs | len < n = replicate (n-len) '0' ++ cs + | otherwise = cs + where len = length cs diff --git a/Util/Lens.hs b/Util/Lens.hs new file mode 100644 --- /dev/null +++ b/Util/Lens.hs @@ -0,0 +1,34 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Lens + ( lowerCamelCaseLensRules + , makeLowerCCLenses + ) where + +import Control.Lens +import Data.Char +import Data.List.Split +import Language.Haskell.TH + + +-- | Rules for makin lower camel case lenses +-- lf_name becomes lfName +lowerCamelCaseLensRules :: LensRules +lowerCamelCaseLensRules = lensRules & lensField .~ lowerCamelCaseNamer + where + lowerCamelCase = concat . (_tail %~ map (_head %~ toUpper)) . splitOn "_" + lowerCamelCaseNamer _ _ n = + case nameBase n of + ('_':_) -> [] + field -> [ TopName $ mkName $ lowerCamelCase field ] + +-- | Make lower camel case lenses +-- lf_name becomes lfName +makeLowerCCLenses :: Name -> DecsQ +makeLowerCCLenses = makeLensesWith lowerCamelCaseLensRules diff --git a/Util/Linter.hs b/Util/Linter.hs new file mode 100644 --- /dev/null +++ b/Util/Linter.hs @@ -0,0 +1,79 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Linter + ( LintError(..) + , Severity(..) + , LintFormat(..) + , parseLintFormat + , reportLintErrors + ) where + +import Data.Aeson (ToJSON(..)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as ByteString +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import GHC.Generics +import Options.Applicative +import TextShow + +import Util.Text + +-- Lint Error Types ------------------------------------------------------------ + +data LintError = LintError + { source_file :: FilePath + , source_line :: Int + , source_col :: Int + , severity :: Severity + , message :: Text + } deriving (Show, Eq, Generic) + +instance ToJSON LintError + +data Severity = Warning | Error + deriving (Show, Eq, Generic) + +instance ToJSON Severity where + toJSON Warning = Aeson.String "warning" + toJSON Error = Aeson.String "error" + +-- Options and Parsers --------------------------------------------------------- + +data LintFormat + = HumanReadable + | JsonDump + +parseLintFormat :: Parser LintFormat +parseLintFormat = flag HumanReadable JsonDump $ mconcat + [ long "json" + , help "Dump output as JSON" + ] + +-- Outputs --------------------------------------------------------------------- + +reportLintErrors :: LintFormat -> [LintError] -> IO () +reportLintErrors HumanReadable errors + | null errors = Text.putStrLn "No errors." + | otherwise = mapM_ (Text.putStrLn . renderLintError) errors +reportLintErrors JsonDump errors = ByteString.putStrLn $ Aeson.encode errors + +renderLintError :: LintError -> Text +renderLintError LintError{..} = Text.unlines $ + colorize + (Text.pack source_file <> ":" <> showt source_line <> ":" <> + showt source_col <> ": " <> Text.pack (show severity)) : + wrapText 2 80 message + where + colorize x = case severity of + -- Warning -> Yellow + Warning -> "\ESC[33m" <> x <> "\ESC[0m" + -- Error -> Red + Error -> "\ESC[31m" <> x <> "\ESC[0m" diff --git a/Util/List.hs b/Util/List.hs new file mode 100644 --- /dev/null +++ b/Util/List.hs @@ -0,0 +1,202 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.List + ( blend + , chunk + , count + , diff + , equalChunksOf + , atMostChunksOf + , splitChunks + , chunkBy + , mapHead + , mapLast + , mostCommonElem + , replace + , sortOnM + , stripSuffix + , uniq + , uniqBy + ) where + +import Data.List +import Data.Ord (comparing) +import qualified Data.Set as Set + +-- This is an O(n+m) implementation for computing difference between two lists, +-- when the order of the result is irrelevant. +-- Returns those elements in the first list which are not present in the second. +-- All occurences of repeated elements are removed. +-- eg. [1,1,2,4,3] `List.diff` [1,2] -> [3,4] +diff :: (Eq a, Ord a) => [a] -> [a] -> [a] +diff xs ys = Set.toList $ Set.fromList xs `Set.difference` Set.fromList ys + +-- | Returns the number of elements that satisfy the predicate +count :: (a -> Bool) -> [a] -> Int +count f = length . filter f + +mapHead :: (a -> a) -> [a] -> [a] +mapHead f (x:xs) = f x : xs +mapHead _ [] = [] + +mapLast :: (a -> a) -> [a] -> [a] +mapLast f = reverse . mapHead f . reverse + +replace :: Eq a => a -> a -> [a] -> [a] +replace a b = map (\x -> if x == a then b else x) + +sortOnM :: (Applicative f, Ord b) => (a -> f b) -> [a] -> f [a] +sortOnM f xs = + map fst . sortOn snd <$> traverse (\x -> (x,) <$> f x) xs + +uniq :: Ord a => [a] -> [a] +uniq = Set.toList . Set.fromList + +uniqBy :: (a -> a -> Ordering) -> [a] -> [a] +uniqBy cmp = map head . groupBy (\a b -> cmp a b == EQ) . sortBy cmp + +-- | Splits list into chunks of roughly equal size 'Int' +-- optimising for variance, which means the chunks can be bigger than the 'Int' +-- and the last chunk can be 50% bigger or 50% smaller than the others. +-- +-- > equalChunksOf 25 [1..99] == [ [1..33], [34..66], [67..99]] +-- > equalChunksOf 34 [1..99] == [ [1..49], [50..99] ] +-- > equalChunksOf 49 [1..99] == [ [1..49], [50..99] ] +-- > equalChunksOf 50 [1..99] == [ [1..99] ] +-- > equalChunksOf 51 [1..99] == [ [1..99] ] +-- +-- > equalChunksOf 24 [1..99] == [ [1..24], [25..48], [49..72], [73..99] ] +-- > -- lengths are 24, 24, 24, 27 where last chunk is 3 larger. +-- > map length $ equalChunksOf 6 [1..81] == [6,6,6,6,6,6,6,6,6,6,6,6,9] +-- > last $ map length $ equalChunksOf 24 [1..348] == 36 -- 50% bigger +-- > last $ map length $ equalChunksOf 24 [1..349] == 13 -- 50% smaller +-- +-- > +-- > equalChunksOf i [] = [ [] ] +-- > equalChunksOf 0 xs -- *** Exception: divide by zero +-- > equalChunksOf (-1) xs == [ xs ] +equalChunksOf :: Int -> [a] -> [[a]] +equalChunksOf n as = go as size [] + where + size = length as + bestLen = size `div` max 1 (size `div` n) + go bs bsLen acc | bsLen <= bestLen * 3 `div` 2 = reverse $ bs:acc + go bs bsLen acc = + let (chunk, rest) = splitAt bestLen bs in + go rest (bsLen - bestLen) $ chunk:acc + +-- | Splits list into non-empty pieces which are at most 'Int' size limit. +-- The actual chunk size will often be smaller (see splitChunks), using +-- the minimum number of chunks to not go over the 'Int' size limit. The size +-- of chunks will all be equal (if possible) and otherwise vary by at most 1. +-- +-- > concat (atMostChunksOf i xs) == xs +-- > all (not . null) (atMostChunksOf i xs) +-- +-- > atMostChunksOf 24 [1..99] == [[1..20],[21..40],[41..60],[61..80],[81..99]] +-- > atMostChunksOf 34 [1..99] == [ [1..33], [34..66], [67..99] ] +-- > atMostChunksOf 49 [1..99] == [ [1..33], [34..66], [67..99] ] +-- > atMostChunksOf 50 [1..99] == [ [1..50], [51..99] ] +-- > atMostChunksOf 51 [1..99] == [ [1..50], [51..99] ] +-- > +-- > atMostChunksOf i [] = [] -- never make an empty chunk by returning [ [] ] +-- > atMostChunksOf 1 [x,y,z] = [ [x], [y], [z] ] +-- > atMostChunksOf 0 [x,y,z] = [ [x,y,z] ] -- nonsense, non-empty list +-- > atMostChunksOf (-1) [x,y,z] = [ [x,y,z] ]-- nonsense, non-empty list +atMostChunksOf :: Int -> [a] -> [[a]] +atMostChunksOf i as + | null as = [] + | i <= 0 = [as] + | size <= i = [as] + | otherwise = splitChunks pieces as + where + size = length as + pieces = (size + pred i) `div` i -- assert size <= pieces * i + +-- | Splits list into at most 'Int' non-empty chunks of nearly equal size. +-- Initial larger chunks can be 1 longer than later smaller chunks. +-- +-- > concat (splitChunks i xs) == xs +-- > all (not . null) (splitChunks i xs) +-- +-- > splitChunks _ [] = [] -- never make an empty chunk by returning [ [] ] +-- > splitChunks 4 [x,y,z] = [ [x], [y], [z] ] -- only 3 non-empty chunks +-- > splitChunks 3 [x,y,z] = [ [x], [y], [z] ] +-- > splitChunks 2 [x,y,z] = [ [x,y], [z] ] -- larger groups first +-- > splitChunks 1 [x,y,z] = [ [x,y,z] ] +-- > splitChunks 0 [x,y,z] = [ [x,y,z] ] -- nonsense, non-empty list +-- > splitChunks (-1) [x,y,z] = [ [x,y,z] ] -- nonsense, non-empty list +splitChunks :: Int -> [a] -> [[a]] +splitChunks b as + | null as = [] + | b <= 0 = [as] + | size <= b = map (:[]) as + | otherwise = go as sizes [] + where + size = length as + larges = size `mod` b -- assert 0 <= larges < b + smalls = b - larges -- assert 0 < smalls <= b + -- assert larges + smalls == b + smaller = size `div` b -- assert 1 <= smaller ; since 0 < b < size + larger = succ smaller -- assert 2 <= larger + sizes = replicate larges larger ++ replicate smalls smaller + -- assert 0 < length sizes == b + -- assert sum sizes == size + go [] _ acc = reverse acc -- base case + go bs (x:xs) acc = + let (chunk, rest) = splitAt x bs -- assert 1 <= length chunk + in go rest xs (chunk:acc) + go bs [] acc = reverse $ bs:acc -- should not happen + +-- | @chunkBy n f xs@: divide @xs@ into chunks of at most size @n@, +-- where the size of an element @x@ of @xs@ is given by @f x@. If the size of +-- any element is greater than @n@, then it will be in a chunk on its own. +-- +-- > chunkBy 4 length ["ab", "cde", "f", "ghijk"] +-- > [["ab"],["cde","f"],["ghijk"]] +-- +chunkBy :: Int -> (a -> Int) -> [a] -> [[a]] +chunkBy _ _ [] = [] +chunkBy chunkSize getSize (x:xs) + | chunkSize <= 0 = [x:xs] + | otherwise = go (getSize x) [x] xs + where + -- invariant: chunk has at least one element + go _ chunk [] = [reverse chunk] + go n chunk (x:xs) + | n + xSize > chunkSize = reverse chunk : go xSize [x] xs + | otherwise = go (n + xSize) (x:chunk) xs + where xSize = getSize x + +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix xs ys + | Just zs <- stripPrefix (reverse xs) (reverse ys) = Just (reverse zs) + | otherwise = Nothing + +-- | Returns the most common element in the list. +-- Throws if given an empty list. +mostCommonElem :: Ord a => [a] -> a +mostCommonElem = head . maximumBy (comparing length) . group . sort + +blend :: [a] -> [a] -> [a] +blend [] _ = [] +blend _ [] = [] +blend (x:xs) (y:ys) = x:y:blend xs ys + +-- | Divide a range @0..(k-1)@ into @n@ chunks. Each pair in the result +-- list is the (start,length) of a chunk. +chunk + :: Int -- ^ @n@ + -> Int -- ^ @k@ + -> [(Int,Int)] -- ^ @[(start,length)]@ +chunk !n !k = zip (scanl (+) 0 lens) lens + where + lens = replicate r (q+1) ++ if q == 0 then [] else replicate (n-r) q + !q = k `div` n + !r = k `mod` n diff --git a/Util/List/HigherOrder.hs b/Util/List/HigherOrder.hs new file mode 100644 --- /dev/null +++ b/Util/List/HigherOrder.hs @@ -0,0 +1,53 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE PolyKinds #-} +module Util.List.HigherOrder + ( fold2 + , map2 + , mapMaybe2 + , concatMap2 + , traverse2, traverse2_ + ) where + +import Data.Foldable + +-- | Efficiently right fold over two lists in sequence that have different +-- parameter types +fold2 :: (forall (z :: k). t z -> b -> b) -> b -> [t x] -> [t y] -> b +fold2 f b xs ys = foldr f (foldr f b ys) xs + +-- | Efficiently map a normalizing function over two lists with different type +-- parameters +map2 :: (forall (z :: k). t z -> b) -> [t x] -> [t y] -> [b] +map2 f xs ys = foldr ((:) . f) (map f ys) xs + +-- | Like map2, but filter out Nothings +mapMaybe2 :: (forall (z :: k). t z -> Maybe b) -> [t x] -> [t y] -> [b] +mapMaybe2 f = fold2 (maybe id (:) . f) [] + +concatMap2 :: (forall (z :: k). t z -> [b]) -> [t x] -> [t y] -> [b] +concatMap2 f xs ys = concat $ map2 f xs ys + +traverse2 + :: Applicative f + => (forall (z :: k). t z -> f a) + -> [t x] + -> [t y] + -> f [a] +traverse2 f (x:xs) ys = (:) <$> f x <*> traverse2 f xs ys +traverse2 f [] ys = traverse f ys + +traverse2_ + :: Applicative f + => (forall (z :: k). t z -> f ()) + -> [t x] + -> [t y] + -> f () +traverse2_ f (x:xs) ys = f x *> traverse2_ f xs ys +traverse2_ f [] ys = traverse_ f ys diff --git a/Util/Log.hs b/Util/Log.hs new file mode 100644 --- /dev/null +++ b/Util/Log.hs @@ -0,0 +1,25 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Log + ( vlog + , logInfo + , logWarning + , logError + , logFatal + , flush + ) where + +import Control.Monad.IO.Class +-- Re-export all String-based logging functions for compatibility +-- with existing code. +import Util.Log.String +import Util.Log.Internal + +flush :: MonadIO m => m () +flush = liftIO c_glog_flush diff --git a/Util/Log/Internal.hs b/Util/Log/Internal.hs new file mode 100644 --- /dev/null +++ b/Util/Log/Internal.hs @@ -0,0 +1,79 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} + +module Util.Log.Internal + ( vlogIsOn + , c_glog_verbose + , c_glog_info + , c_glog_warning + , c_glog_error + , c_glog_fatal + , c_glog_flush + ) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Foreign.C (CString, CInt(..)) + +import Mangle.TH + +$(mangle + "int vlog_is_on(int)" + [d| + foreign import ccall unsafe + c_vlog_is_on :: CInt -> IO CInt + |]) + +$(mangle + "void glog_verbose(const char*, int, const char*)" + [d| + foreign import ccall unsafe + c_glog_verbose :: CString -> CInt -> CString -> IO () + |]) + +$(mangle + "void glog_info(const char*, int, const char*)" + [d| + foreign import ccall unsafe + c_glog_info :: CString -> CInt -> CString -> IO () + |]) + +$(mangle + "void glog_warning(const char*, int, const char*)" + [d| + foreign import ccall unsafe + c_glog_warning :: CString -> CInt -> CString -> IO () + |]) + +$(mangle + "void glog_error(const char*, int, const char*)" + [d| + foreign import ccall unsafe + c_glog_error :: CString -> CInt -> CString -> IO () + |]) + +$(mangle + "void glog_fatal(const char*, int, const char*)" + [d| + foreign import ccall unsafe + c_glog_fatal :: CString -> CInt -> CString -> IO () + |]) + +$(mangle + "void glog_flush()" + [d| + foreign import ccall unsafe + c_glog_flush :: IO () + |]) + +{-# INLINE vlogIsOn #-} +vlogIsOn :: MonadIO m => Int -> m Bool +vlogIsOn level = liftIO $ do + x <- c_vlog_is_on (fromIntegral level) + return (x /= 0) diff --git a/Util/Log/String.hs b/Util/Log/String.hs new file mode 100644 --- /dev/null +++ b/Util/Log/String.hs @@ -0,0 +1,76 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE ImplicitParams #-} + +-- | +-- This module allows you to log things to stderr. Make sure to initialize your +-- application using 'Facebook.Init.initFacebook' or +-- 'Facebook.Init.withFacebook' beforehand. Otherwise you're going to get a +-- cryptic "Logging before InitGoogleLogging() is written to STDERR" error. +module Util.Log.String + ( vlog + , vlogIsOn + , logInfo + , logWarning + , logError + , logFatal + ) where + +import Control.Monad +import Control.Monad.IO.Class (MonadIO, liftIO) +import Foreign.C +import GHC.Stack + +import Util.Log.Internal + +-- | Equivalent to @VLOG(level)@, except that in Haskell we only evaluate +-- the message if verbosity at the desired level is enabled. Note that +-- this lazy evaluation of the message only applies to 'vlog', not to +-- any of the other logging functions. +vlog :: (MonadIO m, HasCallStack) => Int -> String -> m () +vlog level msg = liftIO $ do + b <- vlogIsOn level + when b $ logCommon c_glog_verbose (getCaller $ getCallStack callStack) msg + +-- | The calling point is actually right next to the head as the head is the +-- current function (in this case it would be logInfo/Warning/Error/Fatal). +getCaller :: [(String, SrcLoc)] -> (String, CInt) +getCaller cs = + case cs of + -- Take the first element of the stack if it exists + ((_,sl):_) -> (srcLocFile sl, fromIntegral $ srcLocStartLine sl) + _ -> ("Unknown stack trace", 0) + +-- | Log message at severity level @INFO@. +logInfo :: (MonadIO m, HasCallStack) => String -> m () +logInfo msg = liftIO $ + logCommon c_glog_info (getCaller $ getCallStack callStack) msg + +-- | Log message at severity level @WARNING@. +logWarning :: (MonadIO m, HasCallStack) => String -> m () +logWarning msg = liftIO $ logCommon c_glog_warning + (getCaller $ getCallStack callStack) msg + +-- | Log message at severity level @ERROR@. +logError :: (MonadIO m, HasCallStack) => String -> m () +logError msg = liftIO $ + logCommon c_glog_error (getCaller $ getCallStack callStack) msg + +-- | Log message at severity level @FATAL@. This will terminate the program +-- after the message is logged. +logFatal :: (MonadIO m, HasCallStack) => String -> m () +logFatal msg = + liftIO $ logCommon c_glog_fatal (getCaller $ getCallStack callStack) msg + +logCommon :: (CString -> CInt -> CString -> IO ()) -> + (String, CInt) -> String -> IO () +logCommon fn (file, lineNumber) msg = + withCString file $ \file_cstring -> + withCString msg $ \msg_cstring -> + fn file_cstring lineNumber msg_cstring diff --git a/Util/Log/Text.hs b/Util/Log/Text.hs new file mode 100644 --- /dev/null +++ b/Util/Log/Text.hs @@ -0,0 +1,78 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE ImplicitParams #-} + +-- | +-- This module allows you to log things to stderr. Make sure to initialize your +-- application using 'Facebook.Init.initFacebook' or +-- 'Facebook.Init.withFacebook' beforehand. Otherwise you're going to get a +-- cryptic "Logging before InitGoogleLogging() is written to STDERR" error. +module Util.Log.Text + ( vlog + , vlogIsOn + , logInfo + , logWarning + , logError + , logFatal + ) where + +import Control.Monad +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Text (Text) +import Foreign.C +import GHC.Stack + +import Util.Log.Internal +import Util.Text (useTextAsCString) + +-- | Equivalent to @VLOG(level)@, except that in Haskell we only evaluate +-- the message if verbosity at the desired level is enabled. Note that +-- this lazy evaluation of the message only applies to 'vlog', not to +-- any of the other logging functions. +vlog :: (MonadIO m, HasCallStack) => Int -> Text -> m () +vlog level msg = liftIO $ do + b <- vlogIsOn level + when b $ logCommon c_glog_verbose (getCaller $ getCallStack callStack) msg + +-- | The calling point is actually right next to the head as the head is the +-- current function (in this case it would be logInfo/Warning/Error/Fatal). +getCaller :: [(String, SrcLoc)] -> (String, CInt) +getCaller cs = + case cs of + -- Take the first element of the stack if it exists + ((_,sl):_) -> (srcLocFile sl, fromIntegral $ srcLocStartLine sl) + _ -> ("Unknown stack trace", 0) + +-- | Log message at severity level @INFO@. +logInfo :: (MonadIO m, HasCallStack) => Text -> m () +logInfo msg = + liftIO $ logCommon c_glog_info (getCaller $ getCallStack callStack) msg + +-- | Log message at severity level @WARNING@. +logWarning :: (MonadIO m, HasCallStack) => Text -> m () +logWarning msg = liftIO $ logCommon c_glog_warning + (getCaller $ getCallStack callStack) msg + +-- | Log message at severity level @ERROR@. +logError :: (MonadIO m, HasCallStack) => Text -> m () +logError msg = + liftIO $ logCommon c_glog_error (getCaller $ getCallStack callStack) msg + +-- | Log message at severity level @FATAL@. This will terminate the program +-- after the message is logged. +logFatal :: (MonadIO m, HasCallStack) => Text -> m () +logFatal msg = + liftIO $ logCommon c_glog_fatal (getCaller $ getCallStack callStack) msg + +logCommon :: (CString -> CInt -> CString -> IO ()) -> + (String, CInt) -> Text -> IO () +logCommon fn (file, lineNumber) msg = + withCString file $ \file_cstring -> + useTextAsCString msg $ \msg_cstring -> + fn file_cstring lineNumber msg_cstring diff --git a/Util/LogIfSlow.hs b/Util/LogIfSlow.hs new file mode 100644 --- /dev/null +++ b/Util/LogIfSlow.hs @@ -0,0 +1,57 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module Util.LogIfSlow (logIfSlow, checkUnsafe) where + +import Data.Text (Text) +import Control.Monad +import qualified Data.Text as Text +import Text.Printf +import Util.Timing (timeItNoGC) +import Util.Log.Text as Log + +-- | Logs a message (via @Util.Log.log info@) if the given operation takes +-- longer than a specified threshold in seconds. +-- +logIfSlow + :: Double -- ^ threshold in seconds + -> Text -- ^ description, for the log message + -> IO a -- ^ the operation to time + -> IO a +logIfSlow threshold fun io = do + (t, _, a) <- timeItNoGC io + when (t > threshold) $ + Log.logInfo $ fun <> " took " <> Text.pack (printf "%.2fs" t) + return a + +-- | Logs a message if an unsafe foreign call takes longer than 1ms, +-- which indicates that it should probably not be marked "unsafe". +-- +-- > f = checkUnsafe "c_foo" $ c_foo x y z +-- > foreign import ccall unsafe "foo" c_foo :: ... +-- +-- will log a message (via 'Util.Log.info') if the call to @c_foo@ takes +-- longer than 1ms. +-- +checkUnsafe :: Text -> IO a -> IO a + +#ifdef ENABLE_CHECKUNSAFE + +checkUnsafe fun = logIfSlow badUnsafeCallThreshold msg + where msg = "unsafe foreign call " <> fun + +badUnsafeCallThreshold :: Double +badUnsafeCallThreshold = 0.001 + +#else + +checkUnsafe _ io = io +{-# INLINE checkUnsafe #-} + +#endif diff --git a/Util/Logger.hs b/Util/Logger.hs new file mode 100644 --- /dev/null +++ b/Util/Logger.hs @@ -0,0 +1,53 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Logger + ( ActionLog(..) + , loggingAction ) where + +import Control.Exception +import Data.Int + +import Util.Control.Exception (swallow) +import Util.Timing (timeIt) +import GHC.Stack (HasCallStack, withFrozenCallStack) + +-- | Logs which can log success, failure and time elapsed +class ActionLog l where + successLog :: l + failureLog :: SomeException -> l + timeLog :: Double -> l + allocLog :: Int64 -> l + +-- | Run an action logging success, failure, time elapsed and data about +-- result. +loggingAction + :: (ActionLog l, Monoid l, HasCallStack) + => (l -> IO ()) + -- ^ How to write the log. Typically calls the `runLog` for your + -- `Logger` instance, and it can augment `l` with additional + -- information known about this action. + -> (a -> l) + -- ^ What to log based on the result of the action + -> IO a + -- ^ The action to run + -> IO a +loggingAction log res io = + mask $ \restore -> do + (time,alloc,result) <- timeIt $ try $ restore io + let + logOutcome o = + withFrozenCallStack $ + swallow $ log $ timeLog time `mappend` allocLog alloc `mappend` o + case result of + Right x -> do + logOutcome $ successLog `mappend` res x + return x + Left ex -> do + logOutcome $ failureLog ex + throwIO ex diff --git a/Util/MD5.hs b/Util/MD5.hs new file mode 100644 --- /dev/null +++ b/Util/MD5.hs @@ -0,0 +1,24 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.MD5 (md5) where + +import GHC.Fingerprint +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe +import Data.Text +import System.IO.Unsafe +import Foreign + +import Util.Text + +md5 :: ByteString -> Text +md5 bs = + unsafeDupablePerformIO $ + unsafeUseAsCStringLen bs $ \(ptr,len) -> + textShow <$> fingerprintData (castPtr ptr) (fromIntegral len) diff --git a/Util/Memory.hs b/Util/Memory.hs new file mode 100644 --- /dev/null +++ b/Util/Memory.hs @@ -0,0 +1,74 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +{-# LANGUAGE CPP #-} + +module Util.Memory + ( alloca + , allocaBytes + , allocaBytesAligned + , allocaArray + , allocaArray0 + , with + ) where + +import qualified Util.ASan as A +import qualified Foreign as F + +{-# INLINE alloca #-} +alloca :: F.Storable a => (F.Ptr a -> IO b) -> IO b +-- TODO(T24195918): We need to do this for ABI compatibility between +-- sigma.service and sigma.service.asan. Codemod to __SANITIZE_ADDRESS__ +-- to enable ASAN checks for Haskell allocations. +#ifdef __HASKELL_SANITIZE_ADDRESS__ +alloca = A.alloca +#else +alloca = F.alloca +#endif + +{-# INLINE allocaBytes #-} +allocaBytes :: Int -> (F.Ptr a -> IO b) -> IO b +#ifdef __HASKELL_SANITIZE_ADDRESS__ +allocaBytes = A.allocaBytes +#else +allocaBytes = F.allocaBytes +#endif + +{-# INLINE allocaBytesAligned #-} +allocaBytesAligned :: Int -> Int -> (F.Ptr a -> IO b) -> IO b +#ifdef __HASKELL_SANITIZE_ADDRESS__ +allocaBytesAligned = A.allocaBytesAligned +#else +allocaBytesAligned = F.allocaBytesAligned +#endif + +{-# INLINE allocaArray #-} +allocaArray :: F.Storable a => Int -> (F.Ptr a -> IO b) -> IO b +#ifdef __HASKELL_SANITIZE_ADDRESS__ +allocaArray = A.allocaArray +#else +allocaArray = F.allocaArray +#endif + +{-# INLINE allocaArray0 #-} +allocaArray0 :: F.Storable a => Int -> (F.Ptr a -> IO b) -> IO b +#ifdef __HASKELL_SANITIZE_ADDRESS__ +allocaArray0 = A.allocaArray0 +#else +allocaArray0 = F.allocaArray0 +#endif + +{-# INLINE with #-} +with :: F.Storable a => a -> (F.Ptr a -> IO b) -> IO b +#ifdef __HASKELL_SANITIZE_ADDRESS__ +with = A.with +#else +with = F.with +#endif diff --git a/Util/Monoid.hs b/Util/Monoid.hs new file mode 100644 --- /dev/null +++ b/Util/Monoid.hs @@ -0,0 +1,23 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Monoid + ( mwhen + , munless + ) where + + +-- | Use the supplied value if the condition is 'True', +-- return 'mempty' otherwise. This is like 'guard', but for +-- 'Monoid'. +mwhen :: Monoid m => Bool -> m -> m +mwhen cond v = if cond then v else mempty + +-- | The opposite of `mwhen`. +munless :: Monoid m => Bool -> m -> m +munless = mwhen . not diff --git a/Util/Network.hsc b/Util/Network.hsc new file mode 100644 --- /dev/null +++ b/Util/Network.hsc @@ -0,0 +1,54 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE ForeignFunctionInterface #-} + +module Util.Network + ( ntop6, ntop + ) where + +import Data.ByteString +import Data.Text +import Foreign (nullPtr) +import Foreign.C +import Foreign.Marshal.Alloc (allocaBytes) +import System.IO.Unsafe (unsafePerformIO) + +import Util.Text (cStringToText) + +ntop' :: Int -> Int -> ByteString -> Maybe Text +ntop' inet' inetAddrStrLen' source = + unsafePerformIO $ useAsCString source $ \source' -> + allocaBytes inetAddrStrLen' $ \target -> do + result <- inet_ntop inet' source' target inet6AddrStrLen + if result == nullPtr + then return Nothing + else Just <$> cStringToText result + +ntop6 :: ByteString -> Maybe Text +ntop6 = ntop' inet6 inet6AddrStrLen + +ntop :: ByteString -> Maybe Text +ntop = ntop' inet inetAddrStrLen + +#include + +inet6AddrStrLen :: Int +inet6AddrStrLen = #{ const INET6_ADDRSTRLEN } + +inet6 :: Int +inet6 = #{ const AF_INET6 } + +inetAddrStrLen :: Int +inetAddrStrLen = #{ const INET_ADDRSTRLEN } + +inet :: Int +inet = #{ const AF_INET } + +foreign import ccall unsafe "inet_ntop" + inet_ntop :: Int -> CString -> CString -> Int -> IO CString diff --git a/Util/OptParse.hs b/Util/OptParse.hs new file mode 100644 --- /dev/null +++ b/Util/OptParse.hs @@ -0,0 +1,154 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module Util.OptParse + ( -- * Options + intOption + , doubleOption + , textOption + , maybeStrOption + , maybeTextOption + , maybeIntOption + , textCommaSplit + , testCommaSplitAndStrip + , stringCommaSplit + , readCommaSplit + , absFilePathOption + , relativeFilePathOption + , maybeAbsFilePathOption + , maybeRelativeFilePathOption + , jsonOption + , showHelpText + -- * Commands + , commandParser + -- * Pure Parser + , runParserOnString + -- * Dragons and stuff + , partialParse + ) where + +import Data.Aeson (FromJSON(..), eitherDecodeStrict') +import Data.Bifunctor (second) +import Data.Char (isSpace) +import qualified Data.List.Split as List +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import Options.Applicative +import Options.Applicative.Types + +import Util.FilePath +import Util.String + + +intOption :: Mod OptionFields Int -> Parser Int +intOption = option auto + +doubleOption :: Mod OptionFields Double -> Parser Double +doubleOption = option auto + +textOption :: Mod OptionFields Text -> Parser Text +textOption = option (Text.pack <$> str) + +maybeStrOption :: Mod OptionFields String -> Parser (Maybe String) +maybeStrOption = optional . option str + +maybeTextOption :: Mod OptionFields Text -> Parser (Maybe Text) +maybeTextOption = optional . option (Text.pack <$> str) + +maybeIntOption :: Mod OptionFields Int -> Parser (Maybe Int) +maybeIntOption = optional . option (read <$> str) + +textCommaSplit :: ReadM [Text] +textCommaSplit = Text.splitOn "," . Text.pack <$> str + +testCommaSplitAndStrip :: ReadM [Text] +testCommaSplitAndStrip = map Text.strip <$> textCommaSplit + +stringCommaSplit :: ReadM [String] +stringCommaSplit = List.splitOn "," <$> str + +readCommaSplit :: Read a => ReadM [a] +readCommaSplit = map (read . strip) <$> stringCommaSplit + +jsonOption :: FromJSON a => Mod OptionFields a -> Parser a +jsonOption = + option (eitherReader $ eitherDecodeStrict' . encodeUtf8 . Text.pack) + +-- | Returns an absolute file path, while handling relative paths and ~ +absFilePathOption :: DirEnv -> Mod OptionFields FilePath -> Parser FilePath +absFilePathOption e = option (absolutiseWith e <$> str) + +-- | Returns a relative file path +relativeFilePathOption :: Mod OptionFields FilePath -> Parser FilePath +relativeFilePathOption = option str + + +-- | Returns an absolute file path, while handling relative paths and ~ +maybeAbsFilePathOption + :: DirEnv + -> Mod OptionFields FilePath + -> Parser (Maybe FilePath) +maybeAbsFilePathOption e = optional . option (absolutiseWith e <$> str) + +-- | Returns a relative file path +maybeRelativeFilePathOption + :: Mod OptionFields FilePath + -> Parser (Maybe FilePath) +maybeRelativeFilePathOption = optional . option str + +-- | Build a command subparser from a name, description, and parser. +-- +-- Example: commandParser "foo" (progDesc "Foo does bar.") (... parser ...) +commandParser + :: String -- ^ command name (the 'cmd' in 'prog cmd --cmdflag1') + -> InfoMod a -- ^ command description in --help output + -> Parser a -- ^ parser of command's flags + -> Parser a +commandParser cmd desc p = + subparser $ metavar cmd <> command cmd (info (helper <*> p) desc) + +-- | Run given parser on a string. +runParserOnString :: String -> Parser a -> String -> Either String a +runParserOnString cmdName p args = + case parse of + Success x -> Right x + Failure f -> Left $ fst $ renderFailure f cmdName + CompletionInvoked _ -> Left "Completion Invoked" + where + parse = execParserPure + (prefs mempty) (info (p <**> helper) fullDesc) (quotedWords args) + recurse (w,s) = w : quotedWords s + -- Mimic shell's ability to group tokens with double quotes. + quotedWords s = + case dropWhile isSpace s of + "" -> [] + ('"':cs) -> recurse . second tail $ break (=='"') cs + s' -> recurse $ break isSpace s' + +showHelpText :: ParseError +#if MIN_VERSION_optparse_applicative(0,16,0) +showHelpText = ShowHelpText Nothing +#else +showHelpText = ShowHelpText +#endif + +-- ----------------------------------------------------------------------------- +-- Things from Options.Applicative that have changed + +-- | Attempts to parse across *all* arguments, returning ones that were +-- unrecognized. Fails if a required argument is missing. +partialParse :: ParserPrefs -> ParserInfo a -> [String] -> IO (a, [String]) +partialParse pprefs pinfo args = handleParseResult res + where + pinfo' = pinfo + { infoParser = (,) <$> infoParser pinfo <*> many (strArgument mempty) + , infoPolicy = ForwardOptions + } + res = execParserPure pprefs pinfo' args diff --git a/Util/Predicate.hs b/Util/Predicate.hs new file mode 100644 --- /dev/null +++ b/Util/Predicate.hs @@ -0,0 +1,32 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Predicate + ( Pred + , predAnd + , predTrue + , predFalse + ) where + +import Control.Applicative (liftA2) + +-- | Predicate function. +type Pred a = a -> Bool + +-- | Combine two predicate functions to produce a new function that holds if +-- both input predicates hold. +predAnd :: Pred a -> Pred a -> Pred a +predAnd = liftA2 (&&) + +-- | Predicate which returns True for all inputs +predTrue :: Pred a +predTrue _ = True + +-- | Predicate which returns False for all inputs +predFalse :: Pred a +predFalse _ = False diff --git a/Util/PrettyPrint.hs b/Util/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/Util/PrettyPrint.hs @@ -0,0 +1,72 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.PrettyPrint + ( renderNumWithUnit + , renderPercent + , renderIncrease + , renderNum + , renderInt + , renderBytes + , renderBytesString + ) where + +import Data.Text (Text) +import qualified Data.Text as Text +import Text.Printf +import TextShow + +renderNumWithUnit :: Text -> Double -> Text +renderNumWithUnit unit num = renderNum num <> " " <> unit + +-- | Render a fraction as a percentage +renderPercent :: Double -> Double -> Text +renderPercent x y + | y == 0 = "Infinite" + | otherwise = Text.pack $ printf (printf "%%.%df%%%%" precision) frac + where + frac = x / y * 100 + -- Make sure we always have enough signifigant digits + precision = max 0 $ ceiling (negate $ logBase 10 frac) + 2 :: Int + +-- | Render an increase as either a percent or times +renderIncrease :: Double -> Double -> Text +renderIncrease x y + | y == 0 = "Infinite" + | frac < 2 = renderPercent (x - y) y + | frac < 10 = Text.pack $ printf "%.2fx" frac + | otherwise = showt (round frac :: Int) <> "x" + where + frac = x / y + +renderNum :: Double -> Text +renderNum num + | num < 10 = Text.pack $ printf "%.2f" num + | otherwise = renderInt $ round num + +renderInt :: Int -> Text +renderInt num + | num < 1000 = showt num + | num < 1000000 = showt (num `div` 1000) <> "k" + | otherwise = showt (num `div` 1000000) <> "M" + +renderBytes :: Int -> Text +renderBytes b = Text.pack $ renderBytesString b + +renderBytesString :: Int -> String +renderBytesString b + | b' > gb = printf "%.2f GiB" (b' / gb) + | b' > mb = printf "%.2f MiB" (b' / mb) + | b' > kb = printf "%.2f kiB" (b' / kb) + | otherwise = printf "%d bytes" (fromIntegral b :: Integer) + where + kb, mb, gb :: Double + kb = 1024 + mb = 1024*kb + gb = 1024*mb + b' = fromIntegral b :: Double diff --git a/Util/RWVar.hs b/Util/RWVar.hs new file mode 100644 --- /dev/null +++ b/Util/RWVar.hs @@ -0,0 +1,52 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.RWVar + ( RWVar + , newRWVar + , withReadRWVar + , withWriteRWVar + ) where + +import qualified Control.Concurrent.ReadWriteLock as L +import Data.IORef + +-- | Var holding a value that's only accessible given access to the lock +-- The lock implementation can starve writers +data RWVar a = RWVar (IORef a) L.RWLock + +-- ----------------------------------------------------------------------------- +-- Creation + +-- | Creates a new var that can be read from or written to +newRWVar :: a -> IO (RWVar a) +newRWVar value = do + lock <- L.new + ref <- newIORef value + return $ RWVar ref lock + +-- ----------------------------------------------------------------------------- +-- Reading + +-- | Obtains a read lock and runs the action with the held value +withReadRWVar :: RWVar a -> (a -> IO b) -> IO b +withReadRWVar (RWVar value lock) action = + L.withRead lock $ action =<< readIORef value + +-- ----------------------------------------------------------------------------- +-- Writing + +-- | Obtains a write lock and runs the action with the held value. +-- Overwrites the internal value with the newly computed value. +withWriteRWVar :: RWVar a -> (a -> IO (a, b)) -> IO b +withWriteRWVar (RWVar value lock) action = + L.withWrite lock $ do + old <- readIORef value + (new, ret) <- action old + writeIORef value new + return ret diff --git a/Util/Reader.hs b/Util/Reader.hs new file mode 100644 --- /dev/null +++ b/Util/Reader.hs @@ -0,0 +1,59 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Reader + ( catchR, catchR_ + , bracketR, bracketR_ + , withRetry + ) where + +import Control.Exception +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader + +-- | Same as 'catch' from 'Control.Exception', but lifted into a ReaderT +catchR + :: Exception e + => ReaderT r IO a + -> (e -> ReaderT r IO a) + -> ReaderT r IO a +catchR (ReaderT action) handler = ReaderT $ \env -> + action env `catch` \e -> runReaderT (handler e) env + +-- | Same as 'catchR', but handler doesn't take an argument +catchR_ + :: ReaderT r IO a + -> ReaderT r IO a + -> ReaderT r IO a +catchR_ action handler = action `catchR` \SomeException{} -> handler + +-- | Same as 'bracket' from 'Control.Exception', but lifted into a ReaderT +bracketR + :: ReaderT r IO a -- ^ before + -> (a -> ReaderT r IO b) -- ^ after + -> (a -> ReaderT r IO c) -- ^ computation + -> ReaderT r IO c +bracketR before after thing = ReaderT $ \env -> + bracket (runReaderT before env) + (flip runReaderT env . after) + (flip runReaderT env . thing) + +-- | Same as 'bracket_' from 'Control.Exception', but lifted into a ReaderT +bracketR_ + :: ReaderT r IO a -- ^ before + -> ReaderT r IO b -- ^ after + -> ReaderT r IO c -- ^ computation + -> ReaderT r IO c +bracketR_ before after thing = + bracketR before (const after) (const thing) + +-- | Retries the given computation up to n times if it fails. +-- WARNING: only use this with actions that have NO SIDE EFFECTS on failure +withRetry :: Int -> ReaderT r IO a -> ReaderT r IO a +withRetry n action = foldl catchR action $ replicate n $ + \e@SomeException{} -> do lift $ print e ; action diff --git a/Util/STM.hs b/Util/STM.hs new file mode 100644 --- /dev/null +++ b/Util/STM.hs @@ -0,0 +1,62 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- | Reexports 'Control.Concurrent.STM' +-- adding logging for deadlocks and utility functions +module Util.STM + ( updateTVar + , atomicallyWithLabel + , Util.STM.atomically + , module Control.Concurrent.STM + ) where + +import qualified Control.Concurrent.STM as STM +import Control.Concurrent.STM hiding (atomically) +import Control.Exception (Exception, BlockedIndefinitelyOnSTM, catch, throwIO) +import GHC.Stack +import Data.Typeable (Typeable) + +-- | version of @modifyTVar'@ that returns the new value +updateTVar :: TVar a -> (a -> a) -> STM a +updateTVar var f = do + x <- readTVar var + let !x' = f x + writeTVar var x' + return x' + +-- | Version of 'atomically' that takes a label +atomicallyWithLabel :: String -> STM a -> IO a +atomicallyWithLabel label stm = do + STM.atomically stm `catch` (\(_::BlockedIndefinitelyOnSTM) -> + throwIO (BlockedIndefinitelyOnNamedSTM label)) + +-- | Version of 'atomically' that labels the transaction using the call site +atomically :: HasCallStack => STM a -> IO a +atomically = + atomicallyWithLabel (getCaller $ getCallStack callStack) + +-- | The calling point is actually right next to the head as the head is the +-- current function (in this case it would be logInfo/Warning/Error/Fatal). +getCaller :: [(String, SrcLoc)] -> String +getCaller cs = + case cs of + -- Take the first element of the stack if it exists + ((_,sl):_) -> prettySrcLoc sl + _ -> "Unknown stack trace" + +-- | 'atomicallyWithLabel' replaces occurrences of 'BlockedIndefinitelyOnSTM' w/ +-- 'BlockedIndefinitelyOnNamedSTM', carrying the name of the transaction and +-- thus giving more helpful error messages. +newtype BlockedIndefinitelyOnNamedSTM = BlockedIndefinitelyOnNamedSTM String + deriving (Typeable) + +instance Show BlockedIndefinitelyOnNamedSTM where + showsPrec _ (BlockedIndefinitelyOnNamedSTM name) = + showString $ "thread blocked indefinitely in STM transaction: " ++ name + +instance Exception BlockedIndefinitelyOnNamedSTM diff --git a/Util/Show.hs b/Util/Show.hs new file mode 100644 --- /dev/null +++ b/Util/Show.hs @@ -0,0 +1,27 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Show + ( Pretty(..) + , showBrace + ) where + +-- | Class of human-readable things. Whereas: +-- +-- > read (show x) == x +-- +-- Humans don't care. Uses 'String' and 'ShowS' for now; if this +-- becomes problematic, it can use 'Text' and 'Builder'. +class Pretty a where + prettyPrec :: Int -> a -> ShowS + prettyPrec _ x s = pretty x ++ s + pretty :: a -> String + pretty x = prettyPrec 0 x "" + +showBrace :: ShowS -> ShowS +showBrace s = showString "{ " . s . showString " }" diff --git a/Util/String.hs b/Util/String.hs new file mode 100644 --- /dev/null +++ b/Util/String.hs @@ -0,0 +1,83 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- (c) The University of Glasgow 2006 + +module Util.String + ( capitalize + , decapitalize + , toArgs + , strip + ) where + +import Data.Char (isSpace, toUpper, toLower) +import Control.Applicative + +-- | For processing a string representing a list of arguments into a list of +-- strings, handling surrounding quotes, brackets and spaces. From GHC's Util +-- module. Reproduced here so it can be used without a dependency on GHC. +toArgs :: String -> Either String -- Error + [String] -- Args +toArgs str + = case dropWhile isSpace str of + s@('[':_) -> case reads s of + [(args, spaces)] + | all isSpace spaces -> + Right args + _ -> + Left ("Couldn't read " ++ show str ++ " as [String]") + s -> toArgs' s + where + toArgs' :: String -> Either String [String] + -- Remove outer quotes: + -- > toArgs' "\"foo\" \"bar baz\"" + -- Right ["foo", "bar baz"] + -- + -- Keep inner quotes: + -- > toArgs' "-DFOO=\"bar baz\"" + -- Right ["-DFOO=\"bar baz\""] + toArgs' s = case dropWhile isSpace s of + [] -> Right [] + ('"' : _) -> do + -- readAsString removes outer quotes + (arg, rest) <- readAsString s + (arg:) `fmap` toArgs' rest + s' -> case break (isSpace <||> (== '"')) s' of + (argPart1, s''@('"':_)) -> do + (argPart2, rest) <- readAsString s'' + -- show argPart2 to keep inner quotes + ((argPart1 ++ show argPart2):) `fmap` toArgs' rest + (arg, s'') -> (arg:) `fmap` toArgs' s'' + + readAsString :: String -> Either String (String, String) + readAsString s = case reads s of + [(arg, rest)] + -- rest must either be [] or start with a space + | all isSpace (take 1 rest) -> + Right (arg, rest) + _ -> + Left ("Couldn't read " ++ show s ++ " as String") + + +(<||>) :: Applicative f => f Bool -> f Bool -> f Bool +(<||>) = liftA2 (||) +infixr 2 <||> -- same as (||) + +-- | Strip whitespace from both beginning and end of a string. +strip :: String -> String +strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- | Capitalize the first character of a string. +capitalize :: String -> String +capitalize (x:xs) = toUpper x : xs +capitalize _ = [] + +-- | Decapitalize the first character of a string +decapitalize :: String -> String +decapitalize (x:xs) = toLower x : xs +decapitalize _ = [] diff --git a/Util/String/Quasi.hs b/Util/String/Quasi.hs new file mode 100644 --- /dev/null +++ b/Util/String/Quasi.hs @@ -0,0 +1,30 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} +module Util.String.Quasi (s) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Data.String + +-- | An easy way to write multiline string literals using QuasiQuotes. Useful +-- for e.g. large JSON literals. +-- +-- > [s| this +-- > is a +-- > multi-line string literal with \no escaping\ +-- > |] +-- +s :: QuasiQuoter +s = QuasiQuoter { + quoteExp = \str -> return $ AppE (VarE 'fromString) $ LitE $ StringL str, + quotePat = \_ -> fail "quotePat", + quoteType = \_ -> fail "quoteType", + quoteDec = \_ -> fail "quoteDec" +} diff --git a/Util/Testing.hs b/Util/Testing.hs new file mode 100644 --- /dev/null +++ b/Util/Testing.hs @@ -0,0 +1,84 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE NamedFieldPuns #-} +module Util.Testing + ( assertProperty + , assertPropertyWithArgs + , QC.stdArgs + , QC.Args(..) + , skip + , skipTest + , skipTestIf + , skipTestIfRtsIsProfiled + , skipIf + ) where + +import Control.Exception +import GHC.Stack (HasCallStack) +import System.Environment (lookupEnv) +import System.IO +import Test.HUnit +import Test.HUnit.Lang (HUnitFailure) +import Util.Control.Exception +import qualified Test.QuickCheck as QC + +skip :: String -> IO () +skip msg = hPutStr stderr $ unlines [msg, "***SKIP***"] + +skipIf :: (SomeException -> Bool) -> IO () -> IO () +skipIf f = handleAll $ \e -> if f e then skip (show e) else throw e + +skipTestIf :: (SomeException -> Bool) -> Test -> Test +skipTestIf f (TestCase tc) = TestCase $ skipIf f tc +skipTestIf f (TestList ts) = TestList $ map (skipTestIf f) ts +skipTestIf f (TestLabel l t) = TestLabel l $ skipTestIf f t + +skipTest :: Test -> Test +skipTest = skipTestIf $ const True + +skipTestIfRtsIsProfiled :: Test -> Test +skipTestIfRtsIsProfiled = skipTestIf $ const (rtsIsProfiled /= 0) + +assertProperty + :: (HasCallStack, QC.Testable prop) => String -> prop -> Assertion +assertProperty msg prop = + assertPropertyWithArgs msg QC.stdArgs prop + +assertPropertyWithArgs + :: (HasCallStack, QC.Testable prop) => String -> QC.Args -> prop -> Assertion +assertPropertyWithArgs msg qcArgs prop = do + size <- maybe (QC.maxSize qcArgs) read <$> lookupEnv "QUICKCHECK_SIZE" + success <- + maybe (QC.maxSuccess qcArgs) read <$> lookupEnv "QUICKCHECK_RUNS" + mbSeed <- lookupEnv "QUICKCHECK_SEED" + let args = qcArgs { + QC.maxSize = size, + QC.maxSuccess = success, + QC.replay = (,size) . read <$> mbSeed + } + case QC.replay args of + Just r -> putStrLn $ "Running with replay: " <> show r + _ -> pure () + result <- QC.quickCheckWithResult args prop + case result of + QC.Success{} -> return () + QC.Failure{theException = Just e} + | Just (he :: HUnitFailure) <- fromException e -> throwIO he + QC.Failure{usedSeed, usedSize} + -> assertFailure $ unlines $ + [ msg + , "To reproduce, set:" + , "- QUICKCHECK_SEED=" <> show (show usedSeed) + ] <> + [ "- QUICKCHECK_SIZE=" <> show usedSize + | usedSize /= QC.maxSize QC.stdArgs + ] + _ -> assertFailure msg + +foreign import ccall unsafe "rts_isProfiled" rtsIsProfiled :: Int diff --git a/Util/Text.hs b/Util/Text.hs new file mode 100644 --- /dev/null +++ b/Util/Text.hs @@ -0,0 +1,419 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE CPP #-} + +module Util.Text + ( cStringLenToText + , cStringLenToTextAndByteString + , cStringLenToTextLenient + , cStringToText + , cStringToTextLenient + , newCStringFromText + , useMaybeTextAsCString + , useTextAsCString + , useTextAsCStringLen + , useTextsAsCStrings + , useTextsAsCStringLens + , withCStrings + , textShow + , TextRead(..) + , TextAndByteString(..) + , TextOrByteString(..) + , mkTextAndByteString + , nl + , capitalize + , decapitalize + , insertCommasAndAnd + , toCamelCase + , toPascalCase + , toText + , toUnderscore + , isCfInfixOf + , UnicodeException + , Util.Text.withCStringLen + , useAsPtr + , InvalidConversion(..) + , textToInt + , hexToInt + , hexToBytes + , wrapText + , slice + ) where + +import Control.Arrow (first) +import Control.Exception (Exception, throw) +import qualified Data.Text.Array as A +import Data.Binary +import Data.ByteString (ByteString, useAsCStringLen) +import qualified Data.ByteString as BS +import Data.Char +import Data.Function (on) +import Data.Hashable (Hashable(..)) +import qualified Data.HashMap.Strict as HashMap +import Data.String +import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8', decodeUtf8With) +import Data.Text.Encoding.Error (UnicodeException, lenientDecode) +import Data.Typeable +import Foreign +import Foreign.C +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.Text as Text +import Data.Text.Internal +import qualified Data.Text.Foreign as Text + +import TextShow hiding (toText) +import Util.ByteString +import qualified Util.ASan as ASan + +-- | Executes an 'IO' action with an array of 'CString's marshalled from +-- 'String'. +withCStrings :: [String] -> (Ptr CString -> IO a) -> IO a +withCStrings strs f = go [] strs + where go cs (t:ts) = withCString t $ \c -> go (c:cs) ts + go cs [] = withArray0 nullPtr (reverse cs) f + +-- | Converts a null-terminated 'CString' to 'Text'. +cStringToText :: CString -> IO Text +cStringToText s = do + bs <- B.unsafePackCString s + return $! decodeUtf8 bs + + +cStringToTextLenient :: CString -> IO Text +cStringToTextLenient s = do + bs <- B.unsafePackCString s + return $! decodeUtf8With lenientDecode bs + +-- | Converts a 'CString' with known length to 'Text'. +cStringLenToText :: CString -> Int -> IO Text +cStringLenToText s len = do + bs <- B.unsafePackCStringLen (s, len) + return $! decodeUtf8 bs + +cStringLenToTextAndByteString :: CString -> Int -> IO TextAndByteString +cStringLenToTextAndByteString s len = do + bs <- Char8.packCStringLen (s, len) + return $! mkTextAndByteString bs + +cStringLenToTextLenient :: CString -> Int -> IO Text +cStringLenToTextLenient s len = do + bs <- B.unsafePackCStringLen (s, len) + return $! decodeUtf8With lenientDecode bs + +-- | Executes an 'IO' action with a 'CString' marshalled from 'Just' +-- 'Text', or a 'nullPtr' from 'Nothing'. +useMaybeTextAsCString :: Maybe Text -> (CString -> IO a) -> IO a +useMaybeTextAsCString (Just text) m = useTextAsCString text m +useMaybeTextAsCString Nothing m = m nullPtr + +-- | Executes an 'IO' action with a 'Text' value marshalled as a UTF-8 +-- 'CString'. +useTextAsCString :: Text -> (CString -> IO a) -> IO a +-- TODO(T24195918): We need to do this for ABI compatibility between +-- sigma.service and sigma.service.asan. Codemod to __SANITIZE_ADDRESS__ +-- to enable ASAN checks for Haskell allocations. +#ifdef __HASKELL_SANITIZE_ADDRESS__ +useTextAsCString = ASan.textWithCString +#else +useTextAsCString = BS.useAsCString . encodeUtf8 +#endif + +-- | Executes an 'IO' action with a 'Text' value marshalled as a UTF-8 +-- 'CStringLen'. +useTextAsCStringLen :: Text -> (CStringLen -> IO a) -> IO a +#ifdef __HASKELL_SANITIZE_ADDRESS__ +useTextAsCStringLen = ASan.textWithCStringLen +#else +useTextAsCStringLen = BS.useAsCStringLen . encodeUtf8 +#endif + +-- | Executes an 'IO' action with a '[Text]' value marshalled as a UTF-8 +-- 'Ptr CStringLen'. +useTextsAsCStringLens :: [Text] + -> (Ptr CString -> Ptr CSize -> CSize -> IO a) + -> IO a +useTextsAsCStringLens = bsListAsCStrLenArr . map encodeUtf8 + +{-# INLINE withCStringLen #-} +withCStringLen :: Text -> (CStringLen -> IO a) -> IO a +#ifdef __HASKELL_SANITIZE_ADDRESS__ +withCStringLen = ASan.textWithCStringLen +#else +withCStringLen = Text.withCStringLen +#endif + +-- | Executes an 'IO' action with an array of 'CStrings' marshalled from +-- 'Text'. +useTextsAsCStrings :: [Text] -> (Ptr CString -> IO a) -> IO a +useTextsAsCStrings texts f = go [] texts + where + go cs (t:ts) = + Util.ByteString.useAsCString (encodeUtf8 t) $ \c -> go (c:cs) ts + go cs [] = withArray0 nullPtr (reverse cs) f + +-- | Converts a 'Text' to a 'CString'. The resulting 'CString' must be +-- 'free'd. +newCStringFromText :: Text -> IO CString +newCStringFromText = newCStringFromLazyByteString + . B.fromChunks . (:[]) . encodeUtf8 + +-- | A convenience wrapper for 'Show'. +textShow :: Show a => a -> Text +textShow = Text.pack . show + +{-# INLINE useAsPtr #-} +useAsPtr :: Text -> (Ptr Word16 -> Text.I16 -> IO a) -> IO a +#ifdef __HASKELL_SANITIZE_ADDRESS__ +useAsPtr = ASan.textUseAsPtr +#else +useAsPtr = Text.useAsPtr +#endif + +-- | A pair of a 'Text' and a 'ByteString'. Useful for when we get a +-- value in one format and we want to lazily compute and cache the +-- conversion to the other format. +-- +-- /Note:/ if/when conversion is free (i.e. 'Text' is stored as UTF-8) +-- then we can get rid of this. + +data TextAndByteString = TextAndByteString + { toTextOrError :: Either UnicodeException Text -- deliberately lazy + , toByteString :: ByteString } + deriving Typeable + +toText :: TextAndByteString -> Text +toText v + = case toTextOrError v of + Left e -> throw e + Right v -> v + +instance Eq TextAndByteString where + a == b = toByteString a == toByteString b + +instance Binary TextAndByteString where + put = put . toByteString + get = mkTextAndByteString <$> get + +-- We don't need to show both fields, and indeed the contents might +-- not be valid Text, so the Show instance must show only the +-- ByteString component. +instance Show TextAndByteString where + showsPrec p tbs = + showParen (p > 10) + $ showString "mkTextAndByteString " + . shows (Char8.unpack (fromTextAndByteString tbs)) + -- the showParen is necessary so that instead of e.g. + -- Foo mkTextAndByteString "" + -- we get + -- Foo (mkTextAndByteString "") + +instance Hashable TextAndByteString where + hashWithSalt s = hashWithSalt s . toByteString + +-- | Type-specialised constructor +mkTextAndByteString :: ByteString -> TextAndByteString +mkTextAndByteString = toTextAndByteString + +instance IsString TextAndByteString where + fromString xs = toTextAndByteString (Text.pack xs) + +class TextOrByteString a where + fromTextAndByteString :: TextAndByteString -> a + toTextAndByteString :: a -> TextAndByteString + +instance TextOrByteString Text where + fromTextAndByteString = toText + toTextAndByteString txt = TextAndByteString { + toByteString = encodeUtf8 txt, + toTextOrError = Right txt + } + +instance TextOrByteString ByteString where + fromTextAndByteString = toByteString + toTextAndByteString str = TextAndByteString { + toByteString = str, + toTextOrError = decodeUtf8' str + } + + +-- | Create a number of newlines. +nl :: Int -> Text +nl = flip Text.replicate "\n" + +-- | Capitalize the first non-whitespace character of a Text string. +capitalize :: Text -> Text +capitalize s = ws <> c <> cs + where + (ws, s') = Text.span isSpace s + (c, cs) = first Text.toUpper . Text.splitAt 1 $ s' + +-- | Lowercase the first non-whitespace character of a Text string. +decapitalize :: Text -> Text +decapitalize s = + case Text.uncons t of + Just (c, cs) | c /= toLower c -> ws <> Text.cons (toLower c) cs + _ -> s + where + (ws, t) = Text.span isSpace s + +toCamelCase :: Text -> Text +toCamelCase = decapitalize . toPascalCase + +toPascalCase :: Text -> Text +toPascalCase t = Text.concat $ map capitalize (Text.splitOn "_" t) + +toUnderscore :: Text -> Text +toUnderscore t = Text.intercalate "_" $ + map Text.toLower $ Text.groupBy (\_ i -> not $ isUpper i) t + +-- | Search for substring whilst ignoring case. +isCfInfixOf :: Text -> Text -> Bool +isCfInfixOf = Text.isInfixOf `on` Text.toCaseFold + +class TextRead a where + readText :: Text -> Maybe a + + -- Default implementation for enumerations + default readText :: (Bounded a, Enum a, TextShow a) => Text -> Maybe a + readText = + let + m = HashMap.fromList [ (showt v, v) | v <- [minBound..maxBound] ] + in \t -> HashMap.lookup t m + {-# INLINE readText #-} + +newtype InvalidConversion = InvalidConversion Text + deriving (Typeable, Eq, Show) + +instance Exception InvalidConversion + +-- | Attempts to convert a decimal representation of an integer to an +-- 'Int'. Returns 'Left' with an error message if the input 'Text' +-- was not a valid integer, or 'Right' with the value otherwise. +textToInt :: Text -> Either InvalidConversion Int +textToInt txt@(Text arr off len) + | len == 0 = err + | fromIntegral (A.unsafeIndex arr off) == ord '-' = + if len > 1 + then negate <$> go 0 (off+1) + else err + | otherwise = go 0 off + where + -- Use Text internals for speed. We know that digits are never in + -- the upper range of UTF-16. + go !n !i + | i == len + off = Right n + | c >= 0 && c <= 9 = go (n * 10 + c) (i + 1) + | otherwise = err + where + c = fromIntegral (A.unsafeIndex arr i) - ord '0' + + err = Left . InvalidConversion $ + "textToInt: string \"" <> txt <> "\" is not an integer" + +-- | Attempts to convert a hexadecimal representation of an integer to an +-- 'Int'. Returns 'Left' with an error message if the input 'Text' +-- was not a valid integer, or 'Right' with the value otherwise. +hexToInt :: Text -> Either InvalidConversion Int +hexToInt txt@(Text arr off len) + | len == 0 = err + | fromIntegral (A.unsafeIndex arr off) == ord '-' = + if len > 1 + then negate <$> go 0 (off+1) + else err + | otherwise = go 0 off + where + -- Use Text internals for speed. We know that digits are never in + -- the upper range of UTF-16. + go !n !i + | i == len + off = Right n + | c >= ord '0' && c <= ord '9' = go (n * 16 + c - ord '0') (i + 1) + | c >= ord 'a' && c <= ord 'f' = go (n * 16 + c - ord 'a' + 10) (i + 1) + | c >= ord 'A' && c <= ord 'F' = go (n * 16 + c - ord 'A' + 10) (i + 1) + | otherwise = err + where + c = fromIntegral (A.unsafeIndex arr i) + + err = Left $ InvalidConversion $ + "hexToInt: string \"" <> txt <> "\" is not an integer" + +-- | Convert a hexadecimal representation of an integer to a +-- big-endian ByteString. +hexToBytes :: Text -> Either InvalidConversion ByteString +hexToBytes txt@(Text arr off len) + | len == 0 = err + | otherwise = go [] (off+len-1) + where + go acc !i + | i < off = Right (BS.pack acc) + | i == off, Just x <- nibble l = Right (BS.pack (x:acc)) + | Just x <- nibble l, Just y <- nibble h = + go (y `shiftL` 4 + x : acc) (i-2) + | otherwise = err + where + l = fromIntegral (A.unsafeIndex arr i) + h = fromIntegral (A.unsafeIndex arr (i-1)) + + {-# INLINE nibble #-} + nibble :: Int -> Maybe Word8 + nibble x + | x >= ord '0' && x <= ord '9' = Just (fromIntegral (x - ord '0')) + | x >= ord 'a' && x <= ord 'f' = Just (10 + fromIntegral (x - ord 'a')) + | otherwise = Nothing + + err = Left $ InvalidConversion $ + "hexToBytes: string \"" <> txt <> "\" is not a hex integer" + +insertCommasAndAnd :: [Text] -> Text +insertCommasAndAnd [] = "" +insertCommasAndAnd [x] = x +insertCommasAndAnd [x, y] = x <> " and " <> y +insertCommasAndAnd [x, y, z] = x <> ", " <> y <> ", and " <> z +insertCommasAndAnd (x : xs) = x <> ", " <> insertCommasAndAnd xs + +-- | Break a Text into lines such that each one fits within the given number of +-- characters. +-- NB: this function does not preserve existing whitespace formatting. +wrapText + :: Int -- ^ Indent Amount + -> Int -- ^ Max characters per line + -> Text -- ^ Text to wrap + -> [Text] +wrapText indent maxLength text = concatMap wrapLine $ Text.lines text + where + wrapLine line = case Text.words line of + [] -> [] + [word] -> [word] + w:ws -> wrap (margin <> w) (indent + Text.length w) ws + + wrap acc _ [] = [acc] + wrap acc n (w:ws) + -- If adding the word exceeds the limit, then wrap + | len > maxLength = acc : wrap (margin <> w) (indent + Text.length w) ws + -- Otherwise, add to the current line. Not that there is no length check + -- here. If the word is longer than the max line length then we will put + -- it in anyway. + | otherwise = wrap (acc <> " " <> w) len ws + where + len = n + Text.length w + 1 + margin = Text.replicate indent " " + +-- | The obvious implementation has a performance bug in platform < 011: +-- https://github.com/channable/haskell-string-slicing-benchmarks +slice :: Int -> Int -> Text -> Text +#if MIN_VERSION_text(2,0,0) +slice from len = Text.take len . Text.drop from +#else +slice from len t = + let !t' = Text.drop from t in Text.take len t' +#endif diff --git a/Util/Time.hs b/Util/Time.hs new file mode 100644 --- /dev/null +++ b/Util/Time.hs @@ -0,0 +1,150 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE NamedFieldPuns #-} +module Util.Time + ( -- * absolute time + EpochClock(..) + , getEpochTime, toEpochSeconds, toEpochNanos + , epochClockToUTCTime, showUTC, readUTC + , showEpochTime + -- * time point differences + , TimePoint(..), DiffTimePoints(..), getTimePoint + , addToTimePoint + , diffTimePoints, addDiffTimePoints + , getElapsedTime, elapsedTime + , toDiffMillis, toDiffMicros, toDiffNanos, toDiffSeconds + -- * utils + , delay, nanoseconds, seconds, minutes, hours + ) where + +import Control.Concurrent +import Data.Ratio +import qualified Data.Text as T +import qualified Data.Time.Clock as TC ( UTCTime ) +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime, POSIXTime ) +import Data.Time.Format ( defaultTimeLocale, formatTime, parseTimeM ) +import qualified System.Clock as SC + +import Compat.Prettyprinter as P + +newtype EpochClock = EpochClock SC.TimeSpec deriving (Eq, Ord, Show) + +-- | Use 'Clock' of 'Realtime' +getEpochTime :: IO EpochClock +getEpochTime = EpochClock <$> SC.getTime SC.Realtime + +-- | Using this with 'getEpochTime' and 'showEpochTime' agrees with running +-- +-- > /usr/local/bin/date +'%s' +toEpochSeconds :: EpochClock -> Double +toEpochSeconds (EpochClock SC.TimeSpec{sec, nsec}) = fromRational $ + fromIntegral sec + (fromIntegral nsec % 1000000000) + +toEpochNanos :: EpochClock -> Integer +toEpochNanos (EpochClock timeSpec) = SC.toNanoSecs timeSpec + +-- | Using this with 'getEpochTime' and 'showEpochTime' agrees with running +-- +-- > /usr/local/bin/date --rfc-3339=ns +epochClockToUTCTime :: EpochClock -> TC.UTCTime +epochClockToUTCTime (EpochClock SC.TimeSpec{sec, nsec}) = + let posixSeconds :: POSIXTime + posixSeconds = fromRational $ + fromIntegral sec + (fromIntegral nsec % 1000000000) + in posixSecondsToUTCTime posixSeconds + +-- | For seconds, this has variable number of digits after decimal point. +-- We want to log RFC 3339 format +showUTC :: TC.UTCTime -> T.Text +showUTC = T.pack . formatTime defaultTimeLocale "%FT%X%QZ" + +readUTC :: T.Text -> Maybe TC.UTCTime +readUTC = parseTimeM True defaultTimeLocale "%FT%X%QZ" . T.unpack + +-- | We want to log RFC 3339 format +showEpochTime :: EpochClock -> T.Text +showEpochTime = showUTC . epochClockToUTCTime + +-- ----------------------------------------------------------------------------- + +newtype TimePoint = TimePoint SC.TimeSpec deriving (Eq, Ord, Show) + +instance P.Pretty TimePoint where + pretty (TimePoint SC.TimeSpec{..}) = P.pretty $ "TimePoint " + <> T.pack (show sec) <> "." <> T.justifyRight 9 '0' (T.pack (show nsec)) + +-- | Use 'Clock' of 'MonotonicRaw' +getTimePoint :: IO TimePoint +getTimePoint = TimePoint <$> SC.getTime SC.MonotonicRaw + +newtype DiffTimePoints = DiffTimePoints SC.TimeSpec + deriving (Eq, Ord, Show, Num) + +instance P.Pretty DiffTimePoints where + pretty (DiffTimePoints SC.TimeSpec{..}) = P.pretty $ "DiffTimePoints " + <> T.pack (show sec) <> "." <> T.justifyRight 9 '0' (T.pack (show nsec)) + +addDiffTimePoints :: DiffTimePoints -> DiffTimePoints -> DiffTimePoints +addDiffTimePoints (DiffTimePoints a) (DiffTimePoints b) = DiffTimePoints (a+b) + +-- | This takes the earlier (smaller) then the later (larger) 'TimePoint' +diffTimePoints :: TimePoint -> TimePoint -> DiffTimePoints +diffTimePoints (TimePoint small) (TimePoint big) = + DiffTimePoints (big - small) + +addToTimePoint :: TimePoint -> DiffTimePoints -> TimePoint +addToTimePoint (TimePoint time) (DiffTimePoints diff) = + TimePoint (time + diff) + +getElapsedTime :: TimePoint -> IO DiffTimePoints +getElapsedTime small = do + big <- getTimePoint + return (diffTimePoints small big) + +-- | Measure the elapsed time of an IO action +elapsedTime :: IO a -> IO (DiffTimePoints, a) +elapsedTime io = do + t0 <- getTimePoint + a <- io + delta <- getElapsedTime t0 + return (delta, a) + +-- | We want to log milliseconds, use 'round' +toDiffMillis :: DiffTimePoints -> Int +toDiffMillis (DiffTimePoints SC.TimeSpec{sec,nsec}) = + 1000 * fromIntegral sec + + (round :: Rational -> Int) (fromIntegral nsec % 1000000) + +toDiffMicros :: DiffTimePoints -> Int +toDiffMicros (DiffTimePoints SC.TimeSpec{sec,nsec}) = + 1000000 * fromIntegral sec + + (round :: Rational -> Int) (fromIntegral nsec % 1000) + +toDiffNanos :: DiffTimePoints -> Int +toDiffNanos (DiffTimePoints SC.TimeSpec{sec,nsec}) = + 1000000000 * fromIntegral sec + fromIntegral nsec + +toDiffSeconds :: DiffTimePoints -> Double +toDiffSeconds (DiffTimePoints SC.TimeSpec{sec,nsec}) = + fromIntegral sec + 1e-9 * fromIntegral nsec + +delay :: DiffTimePoints -> IO () +delay = threadDelay . toDiffMicros + +nanoseconds :: Int -> DiffTimePoints +nanoseconds n = DiffTimePoints (SC.fromNanoSecs (fromIntegral n)) + +seconds :: Int -> DiffTimePoints +seconds s = DiffTimePoints (SC.TimeSpec (fromIntegral s) 0) + +minutes :: Int -> DiffTimePoints +minutes m = seconds (m * 60) + +hours :: Int -> DiffTimePoints +hours h = minutes (h * 60) diff --git a/Util/TimeSec.hs b/Util/TimeSec.hs new file mode 100644 --- /dev/null +++ b/Util/TimeSec.hs @@ -0,0 +1,179 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- | Utilities for dealing with time in seconds. This is mostly for +-- interacting with external systems that store or communicate using +-- time in seconds. For higher-resolution times, see "Util.Timing". +module Util.TimeSec + ( Time(..) + , TimeSpan(..) + , TimeRange(..) + , fromUTCTime + , toUTCTime + , addTime, subTime, timeDiff + , addTimeSpan + , now, timeAgo + , minutes, hours, days, weeks + , minute, hour, day, week + , toSeconds, toMinutes, toHours, toDays + , trBetween + , trLength + , trLast + , ppUTCTime, ppDate, ppTime, ppTimeSpan, ppTimeSpanWithGranularity + , PPTimeSpanGranularity(..) + , showNominalDiffTime + ) where + +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Time.Format +import Data.Maybe (catMaybes) +import TextShow + +import GHC.Generics +import Control.DeepSeq +import Data.Hashable + +-- | Unix timestamp. Time in seconds +newtype Time = Time { timeInSeconds :: Int } + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON, TextShow, Num, Enum) + +instance NFData Time +instance Hashable Time + +-- | 'TimeSpan' means a time difference, duration in seconds, +-- as opposed to 'Time', which is a specific point in time +-- (a unix timestamp). +newtype TimeSpan = TimeSpan { timeSpanInSeconds :: Int } + deriving (Show, Eq, Ord) + +data TimeRange = TimeRange + { start :: Time + , end :: Time + } deriving (Show, Eq) + +fromUTCTime :: UTCTime -> Time +fromUTCTime = Time . truncate . utcTimeToPOSIXSeconds + +toUTCTime :: Time -> UTCTime +toUTCTime (Time t) = posixSecondsToUTCTime $ fromIntegral t + +addTime :: Time -> TimeSpan -> Time +addTime (Time t) (TimeSpan d) = Time (t + d) + +subTime :: Time -> TimeSpan -> Time +subTime (Time t) (TimeSpan d) = Time (t - d) + +timeDiff :: Time -> Time -> TimeSpan +timeDiff (Time e) (Time s) = TimeSpan (e - s) + +negateTimeSpan :: TimeSpan -> TimeSpan +negateTimeSpan TimeSpan{..} = TimeSpan (- timeSpanInSeconds) + +addTimeSpan :: TimeSpan -> TimeSpan -> TimeSpan +addTimeSpan t1 t2 = TimeSpan $ timeSpanInSeconds t1 + timeSpanInSeconds t2 + +now :: IO Time +now = fromUTCTime <$> getCurrentTime + +timeAgo :: TimeSpan -> IO Time +timeAgo d = (`subTime` d) <$> now + +minutes, hours, days, weeks :: Int -> TimeSpan +minutes = TimeSpan . (60 *) +hours = TimeSpan . (3600 *) +days = TimeSpan . (86400 *) +weeks = TimeSpan . (604800 *) + +minute, hour, day, week :: TimeSpan +minute = minutes 1 +hour = hours 1 +day = days 1 +week = weeks 1 + +trLength :: TimeRange -> TimeSpan +trLength (TimeRange s e) = timeDiff e s + +trLast :: TimeSpan -> IO TimeRange +trLast d = trBetween d (TimeSpan 0) + +trBetween :: TimeSpan -> TimeSpan -> IO TimeRange +trBetween startDiff endDiff = do + t <- now + return TimeRange + { start = t `subTime` startDiff + , end = t `subTime` endDiff + } + +-- Some generally useful pretty printing functions ----------------------------- + +ppUTCTime :: FormatTime t => t -> Text +ppUTCTime t = ppDate t <> " at " <> ppTime t + +ppDate :: FormatTime t => t -> Text +ppDate = Text.pack . formatTime defaultTimeLocale "%F" -- e.g. 2017-07-20 + +ppTime :: FormatTime t => t -> Text +ppTime = Text.pack . formatTime defaultTimeLocale "%T UTC" -- e.g. 14:18:45 + +data PPTimeSpanGranularity = Day | Hour | Minute | Second + +secondsInOneDay :: Int +secondsInOneDay = 3600 * 24 + +toDays, toHours, toMinutes, toSeconds :: TimeSpan -> Int +toDays TimeSpan{..} = timeSpanInSeconds `div` secondsInOneDay +toHours TimeSpan{..} = (timeSpanInSeconds `mod` secondsInOneDay) `div` 3600 +toMinutes TimeSpan{..} = (timeSpanInSeconds `mod` 3600) `div` 60 +toSeconds TimeSpan{..} = timeSpanInSeconds `mod` 60 + +plural :: Int -> Text -> Maybe Text +plural 0 _ = Nothing +plural 1 unitStr = Just $ "1 " <> unitStr +plural n unitStr = Just $ showt n <> " " <> unitStr <> "s" + +joinTimeSectionString :: Text -> [Maybe Text] -> Text +joinTimeSectionString unitStr maybeSecs = case catMaybes maybeSecs of + [] -> "0" <> unitStr <> "s" + s -> Text.intercalate ", " s + +ppTimeSpanWithGranularity :: PPTimeSpanGranularity -> TimeSpan -> Text +ppTimeSpanWithGranularity g ts | timeSpanInSeconds ts < 0 = + "-" <> ppTimeSpanWithGranularity g (negateTimeSpan ts) +ppTimeSpanWithGranularity Day ts + | timeSpanInSeconds ts < secondsInOneDay = ppTimeSpanWithGranularity Hour ts + | otherwise = joinTimeSectionString "day" [ plural (toDays ts) "day" ] +ppTimeSpanWithGranularity Hour ts + | timeSpanInSeconds ts < 3600 = ppTimeSpanWithGranularity Minute ts + | otherwise = joinTimeSectionString "hour" + [ plural (toDays ts) "day" + , plural (toHours ts) "hour" + ] +ppTimeSpanWithGranularity Minute ts + | timeSpanInSeconds ts < 60 = ppTimeSpanWithGranularity Second ts + | otherwise = joinTimeSectionString "minute" + [ plural (toDays ts) "day" + , plural (toHours ts) "hour" + , plural (toMinutes ts) "minute" + ] +ppTimeSpanWithGranularity Second ts = + joinTimeSectionString "second" + [ plural (toDays ts) "day" + , plural (toHours ts) "hour" + , plural (toMinutes ts) "minute" + , plural (toSeconds ts) "second" + ] + +ppTimeSpan :: TimeSpan -> Text +ppTimeSpan = ppTimeSpanWithGranularity Second + +showNominalDiffTime :: NominalDiffTime -> String +showNominalDiffTime t = Text.unpack (ppTimeSpan (TimeSpan (round t))) diff --git a/Util/Timing.hs b/Util/Timing.hs new file mode 100644 --- /dev/null +++ b/Util/Timing.hs @@ -0,0 +1,88 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +-- | Utilities for timing things and working with time differences +module Util.Timing + ( reportTime + , reportAndShowTime + , showAllocs + , showTime + , timeIt + , timeNF + , timeItNoGC + ) where + +import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) +import Control.Monad.IO.Class +import Data.Int +import Text.Printf +import GHC.Stats +import GHC.Conc +import System.IO (stderr) + +import Util.PrettyPrint +import Util.Time + +-- | Runs an 'IO' operation and prints how long it took. Also returns +-- the timing value for use. +reportAndShowTime :: MonadIO m => String -> m a -> m (Double, Int64, a) +reportAndShowTime name io = do + (t, b, a) <- timeIt io + liftIO $ hPrintf stderr "%s: %s, %s\n" name (showTime t) (showAllocs b) + return (t, b, a) + +-- | Runs an 'IO' operation and reports how long it took. Useful for +-- ad-hoc benchmarking. +reportTime :: MonadIO m => String -> m a -> m a +reportTime name io = do + (_, _, a) <- reportAndShowTime name io + return a + +-- | Converts time in seconds to a human friendly string. +showTime :: Double -> String +showTime t = printf "%.2f%s" val unit + where + unit :: String + (val, unit) + | t >= 1 = (t, "s") + | t >= 1e-3 = (t * 1e3, "ms") + | t >= 1e-6 = (t * 1e6, "us") + | otherwise = (t * 1e9, "ns") + +-- | Converts a number of bytes to a human-friendsly string. +showAllocs :: Int64 -> String +showAllocs = renderBytesString . fromIntegral + +-- | Runs an 'IO' action and returns a triple of the time it consumed (in sec), +-- the number of bytes it allocated, and the result it returned. +timeIt :: MonadIO m => m a -> m (Double, Int64, a) +timeIt action = do + t0 <- liftIO getTimePoint + a0 <- liftIO getAllocationCounter + ret <- action + a1 <- liftIO getAllocationCounter + t <- liftIO $ getElapsedTime t0 + return (toDiffSeconds t, a0 - a1, ret) + +-- | Runs an 'IO' action, reduces the result to normal form and returns a pair +-- of the time it consumed and the result it returned. +timeNF :: NFData a => IO a -> IO (Double, Int64, a) +timeNF action = timeIt $ evaluate . force =<< action + +-- | Records the time to run an action excluding GC time. Probably +-- more expensive than 'timeIt'. +timeItNoGC :: IO a -> IO (Double, Int64, a) +timeItNoGC io = do + t0 <- getRTSStats + a0 <- getAllocationCounter + ret <- io + a1 <- getAllocationCounter + t1 <- getRTSStats + let diff_ns = mutator_elapsed_ns t1 - mutator_elapsed_ns t0 + return (fromIntegral diff_ns / 1000000000, a0 - a1, ret) diff --git a/Util/ToExp.hs b/Util/ToExp.hs new file mode 100644 --- /dev/null +++ b/Util/ToExp.hs @@ -0,0 +1,167 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module Util.ToExp + ( ToExp(..) + , intE + , fracE + , con + , recConstr + , fun + , (=.=) + , (=.==) + , (=.=?) + , (=$=) + , (=$==) + , pp + , ppShow + ) where + +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as BS +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Int +import Data.Scientific +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import qualified Data.Vector.Storable as SVector +import Language.Haskell.Exts hiding (intE) +#if MIN_VERSION_aeson(2,0,0) +import Util.Aeson +#endif +import Util.Text + +infixl 1 =.= +infixl 1 =.== +infixl 1 =.=? +infixl 2 =$= +infixl 2 =$== + +intE :: Integer -> Exp () +intE n = (if n < 0 then paren else id) $ + Lit () (Int () n (show n)) + +fracE :: Rational -> Exp () +fracE n = (if n < 0 then paren else id) $ + Lit () (Frac () n (show n)) + +con :: String -> Exp () +con = Con () . UnQual () . name + +recConstr :: String -> [FieldUpdate ()] -> Exp () +recConstr recname = RecConstr () (UnQual () $ name recname) + +fun :: String -> Exp () +fun = function + +-- | Function used to generate FieldUpdate for record constructors. +(=.=) :: ToExp a => String -> a -> FieldUpdate () +field =.= value = FieldUpdate () (UnQual () $ name field) (toExp value) + +(=.==) :: String -> Exp () -> FieldUpdate () +(=.==) = (=.=) + +(=.=?) :: String -> Maybe (Exp ()) -> FieldUpdate () +(=.=?) = (=.=) + +(=$=) :: ToExp a => Exp () -> a -> Exp () +f =$= x = app f (toExp x) + +(=$==) :: Exp () -> Exp () -> Exp () +(=$==) = (=$=) + +class ToExp a where + toExp :: a -> Exp () + +instance ToExp (Exp ()) where + toExp = id + +instance ToExp () where + toExp () = tuple [] + +instance ToExp Bool where + toExp = con . show + +instance ToExp Int where + toExp = intE . fromIntegral + +instance ToExp Double where + toExp = fracE . realToFrac + +instance ToExp Text where + toExp = strE . Text.unpack + +instance ToExp TextAndByteString where + toExp s = fun "mkTextAndByteString" =$= toByteString s + +instance ToExp BS.ByteString where + toExp = strE . BS.unpack + +instance (ToExp a, ToExp b) => ToExp (a, b) where + toExp (a, b) = tuple [toExp a, toExp b] + +instance ToExp a => ToExp (Maybe a) where + toExp = maybe (con "Nothing") (con "Just" =$=) + +instance ToExp a => ToExp [a] where + toExp = listE . map toExp + +instance ToExp Int64 where + toExp = intE . fromIntegral + +instance ToExp Char where + toExp = charE + + +instance ToExp a => ToExp (Vector.Vector a) where + toExp v = fun "Vector.fromList" =$= Vector.toList v + +instance (SVector.Storable a, ToExp a) + => ToExp (SVector.Vector a) where + toExp v = fun "SVector.fromList" =$= SVector.toList v + +#if MIN_VERSION_aeson(2,0,0) +instance ToExp A.Key where + toExp k = fun "fromText" =$= toExp (keyToText k) + +instance ToExp v => ToExp (KeyMap v) where + toExp m = fun "fromList" =$= objectToList m +#endif + +instance (ToExp k, ToExp v) => ToExp (HashMap k v) where + toExp m = fun "HashMap.fromList" =$= HashMap.toList m + +instance ToExp A.Value where + toExp A.Null = con "Null" + toExp (A.Bool b) = con "Bool" =$= b + toExp (A.Number n) = con "Number" =$== + either toExp toExp (floatingOrInteger n :: Either Double Int) + toExp (A.String s) = con "String" =$= s + toExp (A.Array a) = con "Array" =$= a + toExp (A.Object o) = con "Object" =$= o + +-- TODO(t16157798): remove the OneLineMode; currently dumpCacheAsHaskellFn +-- depends on the output being a single line only +pp :: ToExp a => a -> String +pp x = prettyPrintStyleMode oneline defaultMode $ (noLoc <$ toExp x) + where + oneline = Style{ mode = OneLineMode, lineLength = 0, ribbonsPerLine = 0 } + +-- To define a Show instance based on ToExp, use ppShow instead of pp; +-- the correct definition would define showsPrec and depending on the +-- operator precedence of the enclosing context and on the precedence inside +-- the expression would choose to parenthesize it or not. +-- YOLO. Let's just always parenthesize to be on the safe side. +-- +-- > instance Show Foo where +-- > show = ppShow +ppShow :: ToExp a => a -> String +ppShow x = pp $ paren (toExp x) diff --git a/Util/Typeable.hs b/Util/Typeable.hs new file mode 100644 --- /dev/null +++ b/Util/Typeable.hs @@ -0,0 +1,24 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.Typeable + ( cast1 + ) where + +import Data.Maybe +import Data.Typeable +import Unsafe.Coerce + +-- | A simpler variant of Data.Typeable.gcast1 +{-# INLINE cast1 #-} +cast1 :: (Typeable t, Typeable t') => t a -> Maybe (t' a) +cast1 x = r + where + r = if typeOf1 x == typeOf1 (fromJust r) + then Just $ unsafeCoerce x + else Nothing diff --git a/Util/WBVar.hs b/Util/WBVar.hs new file mode 100644 --- /dev/null +++ b/Util/WBVar.hs @@ -0,0 +1,137 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Util.WBVar ( + WBVar, + newWBVar, newWBVarIO, + readWBVar, writeWBVar, modifyWBVar', dirtyWBVar, + writeBackWBVar, + WBMVar, + newEmptyWBMVar, + newWBMVar, + readWBMVar, + takeWBMVar, + writeWBMVar, + withWBMVar, + modifyWBMVar, +) where + +import Util.Defer + +import Control.Concurrent (forkIO) +import Control.Concurrent.STM +import Control.Exception + +data WBVar a = WBVar + { wbValue :: TVar a + , wbDirty :: TVar Bool + , wbWriting :: TVar Bool + , wbWriteBack :: a -> IO () + } + +newWBVar :: a -> (a -> IO ()) -> STM (WBVar a) +newWBVar x wb = WBVar + <$> newTVar x + <*> newTVar False + <*> newTVar False + <*> pure wb + +newWBVarIO :: a -> (a -> IO ()) -> IO (WBVar a) +newWBVarIO x wb = WBVar + <$> newTVarIO x + <*> newTVarIO False + <*> newTVarIO False + <*> pure wb + +readWBVar :: WBVar a -> STM a +readWBVar = readTVar . wbValue + +writeWBVar :: WBVar a -> a -> Defer IO STM () +writeWBVar v x = do + lift $ writeTVar (wbValue v) x + dirtyWBVar v + +modifyWBVar' :: WBVar a -> (a -> a) -> Defer IO STM () +modifyWBVar' v f = do + lift $ modifyTVar' (wbValue v) f + dirtyWBVar v + +dirtyWBVar :: WBVar a -> Defer IO STM () +dirtyWBVar v = do + lift $ writeTVar (wbDirty v) True + later $ writeBackWBVar v + +-- Write back the variable if it is dirty. +-- +-- NOTE: To avoid blocking an arbitrary number of threads, we'll keep writing +-- until the variable is no longer dirty. Suppose thread T1 is writing back +-- and T2 dirties the variable while this is happening and tries to write back +-- as well. In this situation, T2 will immediately return instead of blocking +-- until T1 is done. T1, on the other hand, will finish writing back, notice +-- that the variable is dirty and write back again. +writeBackWBVar :: WBVar a -> IO () +writeBackWBVar v = do + r <- atomically $ do + dirty <- readTVar $ wbDirty v + if dirty + then do + writing <- readTVar $ wbWriting v + if writing + then return Nothing + else do + writeTVar (wbDirty v) False + writeTVar (wbWriting v) True + Just <$> readTVar (wbValue v) + else return Nothing + case r of + Just x -> do + wbWriteBack v x + `finally` atomically (writeTVar (wbWriting v) False) + -- FIXME: A lame attempt to keep writing even in the case of an + -- exception. I don't think this can really work without atomicity + -- between the STM transaction and the write-back which seems impossible + -- to achieve with STM. + `onException` forkIO (writeBackWBVar v) + writeBackWBVar v + Nothing -> return () + + +-- | A 'WBVar' that can be empty/full like 'MVar' +type WBMVar a = WBVar (Maybe a) + +newWBMVar :: a -> (a -> IO ()) -> STM (WBMVar a) +newWBMVar a f = newWBVar (Just a) (maybe (return ()) f) + +newEmptyWBMVar :: (a -> IO ()) -> STM (WBMVar a) +newEmptyWBMVar f = newWBVar Nothing (maybe (return ()) f) + +readWBMVar :: WBMVar a -> STM a +readWBMVar v = readWBVar v >>= maybe retry return + +takeWBMVar :: WBMVar a -> IO a +takeWBMVar v = atomically $ do + a <- readWBMVar v + writeTVar (wbValue v) Nothing + return a + +writeWBMVar :: WBMVar a -> a -> Defer IO STM () +writeWBMVar v = writeWBVar v . Just + +withWBMVar :: WBMVar a -> (a -> IO b) -> IO b +withWBMVar v = + bracket (takeWBMVar v) (atomically . writeTVar (wbValue v) . Just) + -- omit the write-back, we know the value didn't change. + +modifyWBMVar :: WBMVar a -> (a -> IO (a,b)) -> IO b +modifyWBMVar v f = + mask $ \restore -> do + a <- takeWBMVar v + (a',b) <- restore (f a) + `onException` atomically (writeTVar (wbValue v) (Just a)) + immediately $ writeWBMVar v a' + return b diff --git a/cpp/Constructible.h b/cpp/Constructible.h new file mode 100644 --- /dev/null +++ b/cpp/Constructible.h @@ -0,0 +1,36 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +namespace { + +// Constructs object on already allocated memory. +template +void constructImpl(T* p) noexcept { + new (p) T; +} + +// This allocates memory, and then constructs object. +template +T* newImpl() noexcept { + return new T; +} + +} // namespace + +#ifndef HS_DEFINE_DEFAULT_CONSTRUCTIBLE +#define HS_DEFINE_DEFAULT_CONSTRUCTIBLE(Name, Type...) \ + static_assert(std::is_default_constructible_v); \ + extern "C" void constructible_constructDefault##Name(Type* p) noexcept { \ + constructImpl(p); \ + } \ + extern "C" Type* constructible_newDefault##Name() noexcept { \ + return newImpl(); \ + } +#endif diff --git a/cpp/Destructible.h b/cpp/Destructible.h new file mode 100644 --- /dev/null +++ b/cpp/Destructible.h @@ -0,0 +1,35 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +namespace { + +template +void destructImpl(T* p) noexcept { + if (p != nullptr) { + p->~T(); + } +} + +template +void deleteImpl(T* p) noexcept { + delete p; +} + +} // namespace + +#ifndef HS_DEFINE_DESTRUCTIBLE +#define HS_DEFINE_DESTRUCTIBLE(Name, Type...) \ + extern "C" void destructible_destruct##Name(Type* p) noexcept { \ + destructImpl(p); \ + } \ + extern "C" void destructible_delete##Name(Type* p) noexcept { \ + deleteImpl(p); \ + } +#endif diff --git a/cpp/EventBaseDataplane.cpp b/cpp/EventBaseDataplane.cpp new file mode 100644 --- /dev/null +++ b/cpp/EventBaseDataplane.cpp @@ -0,0 +1,41 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include + +#include + +#include + +extern "C" folly::IOThreadPoolExecutor* +common_hs_eventbase_newExecutor() noexcept { + return new folly::IOThreadPoolExecutor( + sysconf(_SC_NPROCESSORS_ONLN), + std::make_shared("HaskellIOThreadPool")); +} + +extern "C" void common_hs_eventbase_destroyExecutor( + folly::IOThreadPoolExecutor* ex) noexcept { + DCHECK_NOTNULL(ex)->join(); + delete ex; +} + +extern "C" folly::EventBase* common_hs_eventbase_getIOExecutorEventBase( + folly::IOThreadPoolExecutor* io) noexcept { + return DCHECK_NOTNULL(io)->getEventBase(); +} + +extern "C" folly::Executor* common_hs_eventbase_castIOExecutorToExecutor( + folly::IOThreadPoolExecutor* io) noexcept { + return static_cast(io); +} + +extern "C" folly::Executor* common_hs_eventbase_castEventBaseToExecutor( + folly::EventBase* io) noexcept { + return static_cast(io); +} diff --git a/cpp/Executor.cpp b/cpp/Executor.cpp new file mode 100644 --- /dev/null +++ b/cpp/Executor.cpp @@ -0,0 +1,24 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include + +extern "C" folly::Executor::KeepAlive<>* +common_hs_getGlobalCPUExecutor() noexcept { + return new folly::Executor::KeepAlive<>(folly::getGlobalCPUExecutor()); +} + +extern "C" void common_hs_releaseGlobalCPUExecutor( + folly::Executor::KeepAlive<>* e) noexcept { + delete e; +} + +extern "C" folly::Executor* common_hs_getExecutorFromKeepAlive( + folly::Executor::KeepAlive<>* k) noexcept { + return k->get(); +} diff --git a/cpp/HsOption.h b/cpp/HsOption.h new file mode 100644 --- /dev/null +++ b/cpp/HsOption.h @@ -0,0 +1,95 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include +#include + +#include "cpp/HsStructDefines.h" +#include "cpp/Marshallable.h" + +// HsOption ------------------------------------------------------------------- + +#define hsc_derive_hs_option_unsafe(cxx_name...) \ + hsc_printf( \ + "deriveHsOptionUnsafe \"%s\" %lu ", \ + #cxx_name, \ + (unsigned long)sizeof(HsOption)); \ + hsc_printf("%lu", (unsigned long)alignof(HsOption)); + +#define HS_OPTION_H(Name, Type) \ + namespace hs_option { \ + using Name = Type; \ + } + +#define HS_OPTION_CPP(Name, Type...) \ + extern "C" void* option_newHsOption##Name(Type* v) noexcept { \ + return new HsOption(std::move(*v)); \ + } \ + extern "C" void option_ctorHsOption##Name(void* ret, Type* v) noexcept { \ + new (ret) HsOption(std::move(*v)); \ + } \ + HS_DEFINE_MARSHALLABLE(HsOption##Name, FB_SINGLE_ARG(HsOption)) + +template +HS_STRUCT HsOption { + T* value = nullptr; + std::optional opt = std::nullopt; + + public: + HsOption() {} + + /* implicit */ HsOption(T && value) : opt(std::move(value)) { + update(); + } + + template + /* implicit */ HsOption(folly::Optional && value) : opt(std::move(value)) { + update(); + } + + template + /* implicit */ HsOption(std::optional && value) : opt(std::move(value)) { + update(); + } + + HsOption(const HsOption&) = delete; + + HsOption(HsOption && other) noexcept : opt(std::move(other.opt)) { + update(); + other.opt = std::nullopt; // a moved optional doesn't empty the value + other.update(); + } + + HsOption& operator=(const HsOption&) = delete; + + HsOption& operator=(HsOption&& other) noexcept { + opt = std::move(other.opt); + update(); + other.opt = std::nullopt; // a moved optional doesn't empty the value + other.update(); + return *this; + } + + std::optional toStdOptional()&& { + std::optional res = std::move(opt); + opt = std::nullopt; + update(); + return res; + } + + private: + void update() { + if (opt.has_value()) { + value = &opt.value(); + } else { + value = nullptr; + } + } +}; diff --git a/cpp/HsStdTuple.h b/cpp/HsStdTuple.h new file mode 100644 --- /dev/null +++ b/cpp/HsStdTuple.h @@ -0,0 +1,195 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include +#include +#include + +#include "cpp/Destructible.h" +#include "cpp/HsStructDefines.h" + +namespace hs_std_tuple::detail { + +template +T move_one(va_list& args) { + T* l = va_arg(args, T*); + return std::move(*l); +} + +template +std::tuple makeTuple(va_list& args) { + return std::tuple{move_one(args)...}; +} + +template +void peek_one(Tuple* t, va_list& args) { + T* l = va_arg(args, T*); + + if constexpr (std::is_nothrow_move_constructible_v) { + // First delete the default allocated memory + l->~T(); + // Then in-place move initialize + new (l) T(static_cast(std::move(std::get(*t)))); + } else { + *l = std::move(std::get(*t)); + } +} + +template +void peekVals(std::tuple* t, va_list& args, std::index_sequence) { + (peek_one, T, I>(t, args), ...); +} + +} // namespace hs_std_tuple::detail + +#define hsc_derive_hs_std_tuple_unsafe(cxx_name...) \ + hsc_printf( \ + "deriveHsStdTupleUnsafe \"%s\" %lu %lu ", \ + #cxx_name, \ + (unsigned long)sizeof(hs_std_tuple::cxx_name), \ + (unsigned long)alignof(hs_std_tuple::cxx_name)); + +#define HS_STD_TUPLE_H(Name, Types) \ + namespace hs_std_tuple { \ + using Name = HsStdTuple; \ + } + +/** + * `__VA_ARGS__` is no good when the types listed have a comma within them. + * For example, `std::tuple>` breaks as + * `__VA_ARGS__` would give us "int", then "HsEithergetTuplePtr(), \ + args, \ + std::make_index_sequence{}); \ + va_end(args); \ + } + +/** + * std::tuple<> isn't default constructible, which means we can't derive + * `Marshallable` for any `std::tuple`. Since we do really want default + * constructibility, create this intermediate representation that introduces + * default constructibility with DCHECK support when misused. + */ +template +HS_STRUCT HsStdTuple { + union U { + char mem_block[sizeof(std::tuple)]; + std::tuple tup; + + U() : mem_block() {} + ~U() {} + }; + + U data_; + + bool has_tuple_{false}; + + public: + HsStdTuple() : data_(), has_tuple_(false) {} + + explicit HsStdTuple(std::tuple && t) { + new (&data_.tup) decltype(data_.tup){std::move(t)}; + has_tuple_ = true; + } + + HsStdTuple(const HsStdTuple&) = delete; + HsStdTuple& operator=(const HsStdTuple&) = delete; + + HsStdTuple(HsStdTuple && other) noexcept { + construct(std::move(other)); + } + + HsStdTuple& operator=(HsStdTuple&& other) noexcept { + if (this != &other) { + destruct(); + construct(std::move(other)); + } + return *this; + } + + explicit HsStdTuple(va_list & args) { + new (&data_.tup) decltype(data_.tup){ + hs_std_tuple::detail::makeTuple(args)}; + has_tuple_ = true; + } + + ~HsStdTuple() { + destruct(); + } + + std::tuple* getTuplePtr() { + DCHECK(has_tuple_); + return &data_.tup; + } + + std::tuple toStdTuple()&& { + return std::move(data_.tup); + } + + template < + typename T = HsStdTuple, + typename = std::enable_if_t == 2>> + auto toStdPair()&& { + return std::make_pair( + std::move(std::get<0>(data_.tup)), std::move(std::get<1>(data_.tup))); + } + + static constexpr auto tuple_size = std::tuple_size_v>; + + private: + void construct(HsStdTuple && other) noexcept { + DCHECK(this != &other); + has_tuple_ = other.has_tuple_; + if (has_tuple_) { + new (&data_.tup) decltype(data_.tup){std::move(other.data_.tup)}; + } else { + new (&data_.mem_block) decltype(data_.mem_block){ + std::move(*other.data_.mem_block)}; + } + } + + void destruct() { + if (has_tuple_) { + data_.tup.~tuple(); + has_tuple_ = false; + } + } +}; + +namespace std { + +template +struct tuple_size> { + static constexpr size_t value = sizeof...(Ts); +}; + +} // namespace std diff --git a/cpp/HsStdVariant.h b/cpp/HsStdVariant.h new file mode 100644 --- /dev/null +++ b/cpp/HsStdVariant.h @@ -0,0 +1,66 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include +#include +#include + +#include "cpp/Marshallable.h" + +namespace hs_std_variant::detail { + +template +void std_variant_poke(void* var, void* val, uint32_t idx) { + constexpr auto variant_size = std::variant_size_v; + DCHECK_NE(idx, 0); + DCHECK_LT(idx, variant_size); + boost::mp11::mp_with_index(idx, [&](auto tag) { + using type = std::variant_alternative_t; + auto& val_ = *reinterpret_cast(val); + new (var) V{std::in_place_index, std::move(val_)}; + }); +} + +} // namespace hs_std_variant::detail + +// **************************************************************************** + +#define hsc_derive_hs_std_variant_unsafe(cxx_name...) \ + hsc_printf( \ + "deriveHsStdVariantUnsafe \"%s\" %lu ", \ + #cxx_name, \ + (unsigned long)sizeof(hs_std_variant::cxx_name)); \ + hsc_alignment(hs_std_variant::cxx_name); + +#define HS_STD_VARIANT_H(Name, ...) \ + namespace hs_std_variant { \ + using Name = std::variant; \ + } + +#define HS_STD_VARIANT_CPP(Name) \ + HS_PEEKABLE(hs_std_variant::Name); \ + HS_DEFINE_MARSHALLABLE(Name, hs_std_variant::Name) \ + \ + extern "C" void* std_variant_peek##Name(void* var, int32_t* idx) noexcept { \ + constexpr auto variant_size = std::variant_size_v; \ + auto& var_ = *reinterpret_cast(var); \ + *idx = var_.index(); \ + DCHECK_GT(*idx, 0); \ + DCHECK_LT(*idx, variant_size); \ + return boost::mp11::mp_with_index(*idx, [&](auto tag) { \ + return reinterpret_cast(&std::get(var_)); \ + }); \ + } \ + \ + extern "C" void std_variant_poke##Name( \ + void* variant, void* val, int32_t tag) noexcept { \ + hs_std_variant::detail::std_variant_poke( \ + variant, val, tag); \ + } diff --git a/cpp/HsStruct.cpp b/cpp/HsStruct.cpp new file mode 100644 --- /dev/null +++ b/cpp/HsStruct.cpp @@ -0,0 +1,329 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include "cpp/HsStruct.h" + +#include "cpp/Marshallable.h" + +/* + * HsJSON + */ + +HsJSON::HsJSON(const folly::dynamic& value) { + switch (value.type()) { + case folly::dynamic::NULLT: + type = Type::Null; + break; + case folly::dynamic::BOOL: + type = Type::Bool; + integral = value.asBool(); + break; + case folly::dynamic::INT64: + type = Type::Integral; + integral = value.asInt(); + break; + case folly::dynamic::DOUBLE: + type = Type::Real; + real = value.asDouble(); + break; + case folly::dynamic::STRING: + type = Type::String; + new (&string) HsString(value.asString()); + break; + case folly::dynamic::ARRAY: + type = Type::Array; + { + std::vector v; + v.reserve(value.size()); + for (const folly::dynamic& i : value) { + v.emplace_back(i); + } + new (&array) HsArray(std::move(v)); + } + break; + case folly::dynamic::OBJECT: + type = Type::Object; + { + std::vector keys; + std::vector values; + keys.reserve(value.size()); + values.reserve(value.size()); + for (const auto& i : value.items()) { + keys.emplace_back(i.first.asString()); + values.emplace_back(i.second); + } + new (&object) HsObject(std::move(keys), std::move(values)); + } + break; + } +} + +folly::dynamic HsJSON::toDynamic() && { + switch (type) { + case Type::Null: + return folly::dynamic(); + case Type::Bool: + return folly::dynamic(static_cast(integral)); + case Type::Integral: + return folly::dynamic(integral); + case Type::Real: + return folly::dynamic(real); + case Type::String: + return folly::dynamic(std::move(string).toStdString()); + case Type::Array: { + auto res = folly::dynamic::array(); + auto end = std::make_move_iterator(array.end()); + for (auto itr = std::make_move_iterator(array.begin()); itr != end; + itr++) { + res.push_back(std::move(*itr).toDynamic()); + } + return res; + } + case Type::Object: { + folly::dynamic res = folly::dynamic::object; + auto items = std::move(object).take_items(); + + // Manual version of zipping 2 iterators together + auto key_itr = std::make_move_iterator(items.first.begin()); + auto key_end = std::make_move_iterator(items.first.end()); + auto val_itr = std::make_move_iterator(items.second.begin()); + auto val_end = std::make_move_iterator(items.second.end()); + + while (key_itr != key_end && val_itr != val_end) { + res.insert( + std::move(*key_itr).toStdString(), std::move(*val_itr).toDynamic()); + key_itr++; + val_itr++; + } + return res; + } + } + folly::assume_unreachable(); +} + +void HsJSON::construct(HsJSON&& other) { + DCHECK(this != &other); + type = other.type; + switch (type) { + case Type::Null: + break; + case Type::Bool: + case Type::Integral: + integral = other.integral; + break; + case Type::Real: + real = other.real; + break; + case Type::String: + new (&string) HsString(std::move(other.string)); + break; + case Type::Array: + new (&array) HsArray(std::move(other.array)); + break; + case Type::Object: + new (&object) HsObject(std::move(other.object)); + break; + } +} + +void HsJSON::destruct() { + if (type == Type::String) { + string.~HsString(); + } else if (type == Type::Array) { + array.~HsArray(); + } else if (type == Type::Object) { + object.~HsMap(); + } +} + +void ctorHsJSONNull(HsJSON* p) noexcept { + new (p) HsJSON(); +} + +void ctorHsJSONBool(HsJSON* p, bool b) noexcept { + new (p) HsJSON(b); +} + +void ctorHsJSONInt(HsJSON* p, int64_t i) noexcept { + new (p) HsJSON(i); +} + +void ctorHsJSONDouble(HsJSON* p, double d) noexcept { + new (p) HsJSON(d); +} + +void ctorHsJSONString(HsJSON* p, HsString* txt) noexcept { + new (p) HsJSON(std::move(*txt)); +} + +void ctorHsJSONArray(HsJSON* p, HsArray* a) noexcept { + new (p) HsJSON(std::move(*a)); +} + +void ctorHsJSONObject(HsJSON* p, HsObject* o) noexcept { + new (p) HsJSON(std::move(*o)); +} + +/* + * HsObject + */ +extern "C" void common_hs_ctorHsObjectJSON( + HsObject* p, + HsArray* keys, + HsArray* vals) { + new (p) HsObject( + std::move(*keys).toStdVector(), std::move(*vals).toStdVector()); +} + +/* + * HsStringPiece + */ + +HsStringPiece* newHsStringPiece(const char* p, size_t n) noexcept { + return new HsStringPiece(p, n); +} + +void ctorHsStringPiece(HsRange* ret, const char* p, size_t n) noexcept { + new (ret) HsStringPiece(p, n); +} + +/* + * HsString + */ + +HsString* newHsString(const char* p, size_t n) noexcept { + return new HsString(std::string(p, n)); +} + +void ctorHsString(HsString* ret, const char* p, size_t n) noexcept { + new (ret) HsString(std::string(p, n)); +} + +/* + * HsEither + */ + +// HsEither instead of HsEither just to keep class +// definition happy. +void* newHsEither(HsEitherTag tag, void* val) { + return new DummyHsEither(tag, val); +} + +HS_DEFINE_MARSHALLABLE(HsMaybeInt, HsMaybe); +HS_DEFINE_MARSHALLABLE(HsMaybeDouble, HsMaybe); +HS_DEFINE_MARSHALLABLE(HsMaybeString, HsMaybe); + +HS_DEFINE_MARSHALLABLE(HsEitherStringInt, HsEither); +HS_DEFINE_MARSHALLABLE(HsEitherStringDouble, HsEither); +HS_DEFINE_MARSHALLABLE(HsEitherStringString, HsEither); + +HS_DEFINE_MARSHALLABLE( + HsEitherStringArrayInt, + HsEither>); +HS_DEFINE_MARSHALLABLE( + HsEitherStringArrayDouble, + HsEither>); +HS_DEFINE_MARSHALLABLE( + HsEitherStringArrayString, + HsEither>); + +HS_DEFINE_MARSHALLABLE(HsString, HsString); +HS_DEFINE_MARSHALLABLE(HsStringPiece, HsStringPiece); + +HS_DEFINE_MARSHALLABLE(HsArrayInt16, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayInt32, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayInt64, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayUInt8, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayUInt16, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayUInt32, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayUInt64, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayFloat, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayDouble, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayString, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayStringPiece, HsArray); +HS_DEFINE_MARSHALLABLE(HsArrayJSON, HsArray); + +HS_DEFINE_MARSHALLABLE(HsSetInt16, HsSet); +HS_DEFINE_MARSHALLABLE(HsSetInt32, HsSet); +HS_DEFINE_MARSHALLABLE(HsSetInt64, HsSet); +HS_DEFINE_MARSHALLABLE(HsSetUInt8, HsSet); +HS_DEFINE_MARSHALLABLE(HsSetUInt16, HsSet); +HS_DEFINE_MARSHALLABLE(HsSetUInt32, HsSet); +HS_DEFINE_MARSHALLABLE(HsSetUInt64, HsSet); +HS_DEFINE_MARSHALLABLE(HsSetFloat, HsSet); +HS_DEFINE_MARSHALLABLE(HsSetDouble, HsSet); +HS_DEFINE_MARSHALLABLE(HsSetString, HsSet); +HS_DEFINE_MARSHALLABLE(HsSetJSON, HsSet); + +HS_DEFINE_MARSHALLABLE(HsMapIntInt, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapUInt8UInt8, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapUInt16UInt16, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapInt32Int32, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapInt32Double, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapIntDouble, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapIntString, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapInt32String, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapDoubleInt32, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapStringInt32, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapStringInt, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapStringDouble, HsMap); +HS_DEFINE_MARSHALLABLE(HsMapStringString, HsMap); + +HS_DEFINE_MARSHALLABLE(HsObjectJSON, HsObject); +HS_DEFINE_MARSHALLABLE(HsJSON, HsJSON); + +HS_OPTION_CPP(Bool, bool); +HS_OPTION_CPP(UInt8, uint8_t); +HS_OPTION_CPP(Int16, int16_t); +HS_OPTION_CPP(Int32, int32_t); +HS_OPTION_CPP(Int64, int64_t); +HS_OPTION_CPP(UInt32, uint32_t); +HS_OPTION_CPP(UInt64, uint64_t); +HS_OPTION_CPP(Float, float); +HS_OPTION_CPP(Double, double); +HS_OPTION_CPP(String, HsString); +HS_OPTION_CPP(StringView, HsStringPiece); +HS_OPTION_CPP(HsJSON, HsJSON); + +HS_DEFINE_ARRAY_CONSTRUCTIBLE(Int16, int16_t); +HS_DEFINE_ARRAY_CONSTRUCTIBLE(Int32, int32_t); +HS_DEFINE_ARRAY_CONSTRUCTIBLE(Int64, int64_t); +// std::vector doesn't guarantee contiguous memory layout, +// so use HsArray to store one bool per byte +HS_DEFINE_ARRAY_CONSTRUCTIBLE(UInt8, uint8_t); +HS_DEFINE_ARRAY_CONSTRUCTIBLE(UInt16, uint16_t); +HS_DEFINE_ARRAY_CONSTRUCTIBLE(UInt32, uint32_t); +HS_DEFINE_ARRAY_CONSTRUCTIBLE(UInt64, uint64_t); +HS_DEFINE_ARRAY_CONSTRUCTIBLE(Float, float); +HS_DEFINE_ARRAY_CONSTRUCTIBLE(Double, double); +HS_DEFINE_ARRAY_CONSTRUCTIBLE(String, HsString); +HS_DEFINE_ARRAY_CONSTRUCTIBLE(StringView, HsStringPiece); +HS_DEFINE_ARRAY_CONSTRUCTIBLE(HsJSON, HsJSON); + +HS_DEFINE_MAP_CONSTRUCTIBLE(IntInt, int64_t, int64_t); +HS_DEFINE_MAP_CONSTRUCTIBLE(UInt8UInt8, uint8_t, uint8_t); +HS_DEFINE_MAP_CONSTRUCTIBLE(UInt16UInt16, uint16_t, uint16_t); +HS_DEFINE_MAP_CONSTRUCTIBLE(Int32Int32, int32_t, int32_t); +HS_DEFINE_MAP_CONSTRUCTIBLE(Int32Double, int32_t, double); +HS_DEFINE_MAP_CONSTRUCTIBLE(Int32String, int32_t, HsString); +HS_DEFINE_MAP_CONSTRUCTIBLE(DoubleInt32, double, int32_t); +HS_DEFINE_MAP_CONSTRUCTIBLE(StringInt32, HsString, int32_t); +HS_DEFINE_MAP_CONSTRUCTIBLE(StringDouble, HsString, double); +HS_DEFINE_MAP_CONSTRUCTIBLE(StringString, HsString, HsString); + +HS_DEFINE_SET_CONSTRUCTIBLE(Int16, int16_t); +HS_DEFINE_SET_CONSTRUCTIBLE(Int32, int32_t); +HS_DEFINE_SET_CONSTRUCTIBLE(Int64, int64_t); +HS_DEFINE_SET_CONSTRUCTIBLE(UInt8, uint8_t); +HS_DEFINE_SET_CONSTRUCTIBLE(UInt16, uint16_t); +HS_DEFINE_SET_CONSTRUCTIBLE(UInt32, uint32_t); +HS_DEFINE_SET_CONSTRUCTIBLE(UInt64, uint64_t); +HS_DEFINE_SET_CONSTRUCTIBLE(Float, float); +HS_DEFINE_SET_CONSTRUCTIBLE(Double, double); +HS_DEFINE_SET_CONSTRUCTIBLE(String, HsString); +HS_DEFINE_SET_CONSTRUCTIBLE(HsJSON, HsJSON); diff --git a/cpp/HsStruct.h b/cpp/HsStruct.h new file mode 100644 --- /dev/null +++ b/cpp/HsStruct.h @@ -0,0 +1,1027 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include +#include +#include + +#include +#include +#include +#include +#include + +#include "cpp/HsOption.h" +#include "cpp/HsStdTuple.h" +#include "cpp/HsStdVariant.h" +#include "cpp/HsStructDefines.h" +#include "cpp/Marshallable.h" + +#define HS_PEEKABLE(t) \ + static_assert( \ + std::is_standard_layout_v, \ + #t " is a standard-layout class so we can peek it") +#define HS_POKEABLE(t) \ + static_assert( \ + std::is_trivially_destructible_v, \ + #t " is trivially destructible so we can poke it") + +template +HS_STRUCT HsRange { + const T* a = nullptr; + size_t n = 0; + + public: + HsRange() {} + + /* implicit */ HsRange(folly::Range s) : a(s.data()), n(s.size()) {} + + HsRange(const T* a, size_t n) : a(a), n(n) {} + + template < + typename U = T, + typename = typename std::enable_if::value>::type> + explicit HsRange(std::string_view sv) : a(sv.data()), n(sv.size()) {} + + const T* data() const { + return a; + } + + size_t size() const { + return n; + } + + /* implicit */ operator folly::Range() const { + return folly::Range(a, n); + } + + template < + typename U = T, + typename = typename std::enable_if::value>::type> + std::string_view toStdStringView() { + return std::string_view(a, n); + } +}; + +using HsStringPiece = HsRange; + +using DummyHsRange = HsRange; +HS_PEEKABLE(DummyHsRange); +HS_POKEABLE(DummyHsRange); +static_assert( + sizeof(HsStringPiece) == sizeof(DummyHsRange), + "HsStringPiece is of the same size as DummyHsRange"); + +template +HS_STRUCT HsMaybe { + const T* ptr = nullptr; + + public: + HsMaybe() {} + + /* implicit */ HsMaybe(T && value) : ptr(new T(std::move(value))) {} + + /* implicit */ HsMaybe(std::unique_ptr && value) : ptr(value.release()) {} + + template + /* implicit */ HsMaybe(folly::Optional && value) { + if (value.hasValue()) { + ptr = new T(std::move(value).value()); + } + } + + template + /* implicit */ HsMaybe(std::optional && value) { + if (value.has_value()) { + ptr = new T(std::move(value).value()); + } + } + + template + explicit HsMaybe(std::in_place_t, Args && ... args) + : ptr(new T(std::forward(args)...)) {} + + HsMaybe(const HsMaybe&) = delete; + + HsMaybe(HsMaybe && other) noexcept : ptr(other.ptr) { + other.ptr = nullptr; + } + + HsMaybe& operator=(const HsMaybe&) = delete; + + HsMaybe& operator=(HsMaybe&& other) noexcept { + if (this != &other) { + delete ptr; + ptr = other.ptr; + other.ptr = nullptr; + } + return *this; + } + + ~HsMaybe() { + delete ptr; + } + + bool hasValue() const { + return ptr != nullptr; + } + + const T& value() const { + if (hasValue()) { + return *ptr; + } else { + throw std::logic_error("HsMaybe does not have value"); + } + } +}; + +using DummyHsMaybe = HsMaybe; +HS_PEEKABLE(DummyHsMaybe); +static_assert( + sizeof(HsMaybe) == sizeof(DummyHsMaybe), + "HsMaybe is of the same size as DummyHsMaybe"); + +/* + * Generic HsEither implementation. + */ + +enum HsEitherTag { HS_LEFT, HS_RIGHT }; + +enum HsLeftTag { HsLeft }; + +enum HsRightTag { HsRight }; + +template +HS_STRUCT HsEither { + bool isLeft; + union { + L* left; + R* right; + }; + friend void* newHsEither(HsEitherTag, void*); + + public: + template + explicit HsEither(HsLeftTag, Args && ... args) + : isLeft(true), left(new L(std::forward(args)...)) {} + + template + explicit HsEither(HsRightTag, Args && ... args) + : isLeft(false), right(new R(std::forward(args)...)) {} + + template + HsEither() { + static_assert(std::is_default_constructible_v); + isLeft = true; + left = new L; + } + + template + /* implicit */ HsEither(folly::Try && value) + : isLeft(value.hasException()) { + if (isLeft) { + left = new L(std::move(value).exception()); + } else { + right = new R(std::move(value).value()); + } + } + + HsEither(const HsEither&) = delete; + + HsEither(HsEither && other) noexcept { + construct(std::move(other)); + } + + HsEither& operator=(const HsEither&) = delete; + + HsEither& operator=(HsEither&& other) noexcept { + if (this != &other) { + destruct(); + construct(std::move(other)); + } + return *this; + } + + ~HsEither() { + destruct(); + } + + private: + void construct(HsEither && other) noexcept { + DCHECK(this != &other); + isLeft = other.isLeft; + if (isLeft) { + left = new L(std::move(*other.left)); + } else { + right = new R(std::move(*other.right)); + } + } + + void destruct() { + if (isLeft) { + delete left; + } else { + delete right; + } + } + + explicit HsEither(HsEitherTag tag, void* val) { + switch (tag) { + case HS_LEFT: + isLeft = true; + left = static_cast(val); + break; + case HS_RIGHT: + isLeft = false; + left = static_cast(val); + break; + default: + __builtin_unreachable(); + } + } + + public: + bool hasLeft() const { + return isLeft; + } + + bool hasRight() const { + return !isLeft; + } + + const L& getLeft() const { + if (hasLeft()) { + return *left; + } else { + throw std::logic_error("HsEither does not have left"); + } + } + + const R& getRight() const { + if (hasRight()) { + return *right; + } else { + throw std::logic_error("HsEither does not have right"); + } + } +}; + +using DummyHsEither = HsEither; +HS_PEEKABLE(DummyHsEither); +static_assert( + sizeof(HsEither) == sizeof(DummyHsEither), + "HsEither is of the same size as DummyHsEither"); + +extern void* newHsEither(HsEitherTag, void*); + +/* + * A generic HsPair implementation, which stores pointers to the first and + * second elements of the pair. This indirection causes poor performance, so + * if you're using it for e.g. complex pairs "((a,b),(c,d))" or in hot code + * path - you probably want to spin your own pair implementation with + * concrete types, like: + * + * HS_STRUCT HsPairXY { + * X x; + * Y y; + * } + * + * For simple cases, this should be fine. + */ +template +HS_STRUCT HsPair { + F* fst_; + S* snd_; + + public: + template + /* implicit */ HsPair(std::pair && pair) + : fst_(new F(std::move(pair.first))), + snd_(new S(std::move(pair.second))) {} + + /* implicit */ HsPair(F && f, S && s) + : fst_(new F(std::move(f))), snd_(new S(std::move(s))) {} + + HsPair(const HsPair&) = delete; + + HsPair(HsPair && other) noexcept + : fst_(new F(std::move(*other.fst_))), + snd_(new S(std::move(*other.snd_))) {} + + HsPair& operator=(const HsPair&) = delete; + + HsPair& operator=(HsPair&& other) noexcept { + *fst_ = std::move(*other.fst_); + *snd_ = std::move(*other.snd_); + } + + ~HsPair() { + delete fst_; + delete snd_; + } + + const F& first() const { + return *fst_; + } + + const S& second() const { + return *snd_; + } +}; + +using DummyHsPair = HsPair; +HS_PEEKABLE(DummyHsPair); +static_assert( + sizeof(HsPair) == sizeof(DummyHsPair), + "HsPair is of the same size as DummyHsPair"); + +HS_STRUCT HsString { + std::string s_; + const char* str = s_.data(); + size_t len = s_.size(); + + public: + HsString() {} + + /* implicit */ HsString(std::string s) : s_(std::move(s)) {} + + explicit HsString(const folly::exception_wrapper& e) + : s_(e.what().toStdString()) {} + + HsString(const HsString& other) noexcept : s_(other.s_) {} + + HsString(HsString && other) noexcept : s_(std::move(other.s_)) {} + + HsString& operator=(const HsString& other) noexcept { + if (this != &other) { + s_ = other.s_; + update(); + } + return *this; + } + + HsString& operator=(HsString&& other) noexcept { + if (this != &other) { + s_ = std::move(other.s_); + update(); + } + return *this; + } + + HsString& operator=(std::string&& other) noexcept { + if (&(this->s_) != &other) { + s_ = std::move(other); + update(); + } + return *this; + } + + private: + void update() { + str = s_.data(); + len = s_.size(); + } + + public: + const std::string& getStr() const { + return s_; + } + + size_t size() const { + return s_.size(); + } + + const char* data() const { + return s_.data(); + } + + char* mutable_data() { + update(); + return const_cast(s_.data()); + } + + void resize(size_t capacity) { + s_.resize(capacity); + update(); + } + + void clear() { + s_.clear(); + update(); + } + + void append(const char* src, int n) { + s_.append(src, n); + update(); + } + + void append(const HsString& src) { + s_.append(src.s_); + update(); + } + + std::string toStdString()&& { + std::string res(std::move(s_)); + update(); + return res; + } +}; + +inline bool operator<(const HsString& lhs, const HsString& rhs) { + return lhs.getStr() < rhs.getStr(); +} + +HS_PEEKABLE(HsString); + +template +HS_STRUCT HsArray { + static_assert(!std::is_same_v, "Use HsArray instead"); + std::vector v_; + const T* a = v_.data(); + size_t n = v_.size(); + + public: + HsArray() {} + + /* implicit */ HsArray(std::vector && v) : v_(std::move(v)) {} + + template + HsArray(InputIterator first, InputIterator last) : v_(first, last) {} + + template + HsArray(Container && c) + : v_(std::make_move_iterator(c.begin()), + std::make_move_iterator(c.end())) {} + + HsArray(std::initializer_list init) : v_(init) {} + + HsArray(const HsArray& other) : v_(other.v_) {} + + HsArray(HsArray && other) noexcept : v_(std::move(other.v_)) {} + + HsArray& operator=(const HsArray& other) { + if (this != other) { + v_ = other.v_; + update(); + } + return *this; + } + + HsArray& operator=(HsArray&& other) noexcept { + if (this != &other) { + v_ = std::move(other.v_); + update(); + } + return *this; + } + + private: + void update() { + a = v_.data(); + n = v_.size(); + } + + public: + using Iterator = typename std::vector::iterator; + using ConstIterator = typename std::vector::const_iterator; + + void reserve(size_t capacity) { + v_.reserve(capacity); + update(); + } + + void clear() { + v_.clear(); + update(); + } + + Iterator begin() { + return v_.begin(); + } + + Iterator end() { + return v_.end(); + } + + ConstIterator begin() const { + return v_.begin(); + } + + ConstIterator end() const { + return v_.end(); + } + + template + void add(Args && ... args) { + v_.emplace_back(std::forward(args)...); + update(); + } + + T& operator[](size_t index) { + return v_[index]; + } + + const T& operator[](size_t index) const { + return v_[index]; + } + + size_t size() const { + return v_.size(); + } + + std::vector toStdVector()&& { + auto res = std::move(v_); + clear(); + return res; + } +}; + +using DummyHsArray = HsArray; +HS_PEEKABLE(DummyHsArray); +static_assert( + sizeof(HsArray) == sizeof(DummyHsArray), + "HsArray is of the same size as DummyHsArray"); +static_assert(sizeof(HsArray) == sizeof(DummyHsArray)); + +#define HS_DEFINE_ARRAY_CONSTRUCTIBLE(Name, Type) \ + extern "C" HsArray* vector_newHsArray##Name(size_t len) { \ + auto arr = new HsArray(); \ + arr->reserve(len); \ + return arr; \ + } \ + \ + extern "C" void vector_constructHsArray##Name( \ + HsArray* arr, size_t len) { \ + new (arr) HsArray(); \ + arr->reserve(len); \ + } \ + \ + extern "C" void vector_addHsArray##Name(HsArray* arr, Type* val) { \ + arr->add(std::move(*val)); \ + } + +template +HS_STRUCT HsSet { + std::vector k_; + const Key* keys = k_.data(); + size_t n = k_.size(); + + public: + HsSet() {} + + /* implicit */ HsSet(std::vector && k) : k_(std::move(k)) {} + + /* implicit */ HsSet(std::unordered_set && s) { + std::vector k; + k.reserve(s.size()); + while (!s.empty()) { + auto nh = s.extract(s.begin()); + k.insert(std::move(nh.value())); + } + this->k_ = k; + update(); + } + + template + /* implicit */ HsSet(InputIterator first, InputIterator last) { + reserve(std::distance(first, last)); + for (auto it = first; it != last; ++it) { + auto val = *it; + add(std::move(val)); + } + update(); + } + + template + /* implicit */ HsSet(Container && c) + : HsSet( + std::make_move_iterator(c.begin()), + std::make_move_iterator(c.end())) {} + + /* implicit */ HsSet(std::initializer_list init) + : HsSet(init.begin(), init.end()) {} + + HsSet(const HsSet&) = delete; + + HsSet(HsSet && other) noexcept : k_(std::move(other.k_)) { + update(); + } + + HsSet& operator=(const HsSet&) = delete; + + HsSet& operator=(HsSet&& other) noexcept { + if (this != &other) { + k_ = std::move(other.k_); + update(); + } + + return *this; + } + + private: + void update() { + keys = k_.data(); + n = k_.size(); + } + + public: + struct ConstIterator { + const HsSet& object; + size_t index = 0; + + explicit ConstIterator(const HsSet& object) : object(object) {} + + bool isValid() const { + return index < object.n; + } + + void next() { + ++index; + } + + const Key& get() const { + DCHECK(isValid()); + return object.keys[index]; + } + + ConstIterator getIterator() const { + return ConstIterator(*this); + } + }; + + void reserve(size_t capacity) { + k_.reserve(capacity); + update(); + } + + void clear() { + k_.clear(); + update(); + } + + std::vector toStdVector()&& { + auto res = std::move(k_); + update(); + return res; + } + + std::unordered_set toStdUnorderedSet()&& { + auto k = std::move(k_); + std::unordered_set res( + std::make_move_iterator(k.begin()), std::make_move_iterator(k.end())); + update(); + return res; + } + + template + void add(Arg && arg) { + k_.emplace_back(std::forward(arg)); + update(); + } +}; + +using DummyHsSet = HsSet; +HS_PEEKABLE(DummyHsSet); +static_assert( + sizeof(HsSet) == sizeof(DummyHsSet), + "HsSet is of the same size as DummyHsSet"); +static_assert(sizeof(HsSet) == sizeof(DummyHsSet)); + +#define HS_DEFINE_SET_CONSTRUCTIBLE(Name, Type) \ + extern "C" void set_constructHsSet##Name(HsSet* set, size_t len) { \ + new (set) HsSet(); \ + set->reserve(len); \ + } \ + \ + extern "C" void set_addHsSet##Name(HsSet* set, Type* val) { \ + set->add(std::move(*val)); \ + } + +template +HS_STRUCT HsMap { + std::vector k_; + std::vector v_; + const Key* keys = k_.data(); + const Value* values = v_.data(); + size_t n = k_.size(); + + public: + HsMap() {} + + HsMap(std::vector && k, std::vector && v) + : k_(std::move(k)), v_(std::move(v)) { + DCHECK(k_.size() == v_.size()); + } + + template + HsMap(InputIterator first, InputIterator last) { + reserve(std::distance(first, last)); + for (auto it = first; it != last; ++it) { + // when `it` is a `move_iterator`, the content will be moved; + // otherwise, the content will be copied. + auto value = *it; + add(std::move(value.first), std::move(value.second)); + } + } + + template + HsMap(Container && c) + : HsMap( + std::make_move_iterator(c.begin()), + std::make_move_iterator(c.end())) {} + + HsMap(std::initializer_list> init) + : HsMap(init.begin(), init.end()) {} + + HsMap(const HsMap&) = delete; + + HsMap(HsMap && other) noexcept + : k_(std::move(other.k_)), v_(std::move(other.v_)) {} + + HsMap& operator=(const HsMap&) = delete; + + HsMap& operator=(HsMap&& other) noexcept { + if (this != &other) { + k_ = std::move(other.k_); + v_ = std::move(other.v_); + update(); + } + return *this; + } + + private: + void update() { + DCHECK(k_.size() == v_.size()); + keys = k_.data(); + values = v_.data(); + n = k_.size(); + } + + public: + struct ConstIterator { + const HsMap& object; + size_t index = 0; + + explicit ConstIterator(const HsMap& object) : object(object) {} + + bool isValid() const { + return index < object.n; + } + + void next() { + ++index; + } + + const Key& getKey() const { + DCHECK(isValid()); + return object.keys[index]; + } + + const Value& getValue() const { + DCHECK(isValid()); + return object.values[index]; + } + }; + + ConstIterator getIterator() const { + return ConstIterator(*this); + } + + void reserve(size_t capacity) { + k_.reserve(capacity); + v_.reserve(capacity); + update(); + } + + void clear() { + k_.clear(); + v_.clear(); + update(); + } + + std::pair, std::vector> take_items()&& { + auto res = std::make_pair(std::move(k_), std::move(v_)); + update(); + return res; + } + + template + void add(Arg && arg, Args && ... args) { + k_.emplace_back(std::forward(arg)); + try { + v_.emplace_back(std::forward(args)...); + } catch (...) { + k_.pop_back(); + throw; + } + update(); + } + + // This is a linear lookup which is supposed to be used when you only want + // to marshal a single entry of the whole map (e.g. in fbobjAttr). + const Value* getPtr(const Key& key) const { + // The last mapping overrides the previous ones + for (int i = static_cast(k_.size()) - 1; i >= 0; --i) { + if (k_[i] == key) { + return &v_[i]; + } + } + return nullptr; + } + + template + typename std::enable_if< + std::is_same::value && + std::is_convertible::value, + const Value*>::type + getPtr(const T& key) const { + // The last mapping overrides the previous ones + for (int i = static_cast(k_.size()) - 1; i >= 0; --i) { + if (folly::StringPiece(k_[i].getStr()) == key) { + return &v_[i]; + } + } + return nullptr; + } +}; + +#define HS_DEFINE_MAP_CONSTRUCTIBLE(Name, KeyType, ValType) \ + extern "C" void map_constructHsMap##Name( \ + HsMap* map, size_t len) { \ + new (map) HsMap(); \ + map->reserve(len); \ + } \ + extern "C" void map_addHsMap##Name( \ + HsMap* map, KeyType* key, ValType* val) { \ + map->add(std::move(*key), std::move(*val)); \ + } + +template +using HsIntMap = HsMap; +using DummyHsIntMap = HsIntMap; +HS_PEEKABLE(DummyHsIntMap); + +template +using HsObject = HsMap; +using DummyHsObject = HsObject; +HS_PEEKABLE(DummyHsObject); + +static_assert( + sizeof(HsIntMap) == sizeof(DummyHsIntMap) && + sizeof(HsObject) == sizeof(DummyHsObject) && + sizeof(DummyHsIntMap) == sizeof(DummyHsObject), + "All HsMap must have the same size"); + +class HsJSON { + public: + enum class Type { + Null, + Bool, + Integral, + Real, + String, + Array, + Object, + }; + +#ifdef __HSC2HS__ + public: +#else + private: +#endif + + Type type; + union { + std::nullptr_t data; + int64_t integral; + double real; + HsString string; + HsArray array; + HsObject object; + }; + + public: + /* implicit */ HsJSON() : type(Type::Null) {} + + /* implicit */ HsJSON(bool value) : type(Type::Bool), integral(value) {} + + /* implicit */ HsJSON(int64_t value) + : type(Type::Integral), integral(value) {} + + /* implicit */ HsJSON(double value) : type(Type::Real), real(value) {} + + /* implicit */ HsJSON(HsString&& value) + : type(Type::String), string(std::move(value)) {} + + /* implicit */ HsJSON(HsArray&& value) + : type(Type::Array), array(std::move(value)) {} + + /* implicit */ HsJSON(HsObject&& value) + : type(Type::Object), object(std::move(value)) {} + + /* implicit */ HsJSON(const folly::dynamic& value); + + HsJSON(const HsJSON&) = delete; + + HsJSON(HsJSON&& other) noexcept { + construct(std::move(other)); + } + + HsJSON& operator=(const HsJSON&) = delete; + + HsJSON& operator=(HsJSON&& other) noexcept { + if (this != &other) { + destruct(); + construct(std::move(other)); + } + return *this; + } + + ~HsJSON() { + destruct(); + } + + private: + void construct(HsJSON&& other); + + void destruct(); + + public: + Type getType() const { + return type; + } + + int64_t asIntegral() const { + DCHECK(type == Type::Bool || type == Type::Integral); + return integral; + } + + int64_t& asIntegral() { + DCHECK(type == Type::Bool || type == Type::Integral); + return integral; + } + + double asReal() const { + DCHECK(type == Type::Real); + return real; + } + + double& asReal() { + DCHECK(type == Type::Real); + return real; + } + + const HsString& asString() const { + DCHECK(type == Type::String); + return string; + } + + HsString& asString() { + DCHECK(type == Type::String); + return string; + } + + const HsArray& asArray() const { + DCHECK(type == Type::Array); + return array; + } + + HsArray& asArray() { + DCHECK(type == Type::Array); + return array; + } + + const HsObject& asObject() const { + DCHECK(type == Type::Object); + return object; + } + + HsObject& asObject() { + DCHECK(type == Type::Object); + return object; + } + + folly::dynamic toDynamic() &&; +}; + +HS_PEEKABLE(HsJSON); + +HS_OPTION_H(Bool, bool) +HS_OPTION_H(UInt8, uint8_t) +HS_OPTION_H(Int16, int16_t) +HS_OPTION_H(Int32, int32_t) +HS_OPTION_H(Int64, int64_t) +HS_OPTION_H(UInt32, uint32_t) +HS_OPTION_H(UInt64, uint64_t) +HS_OPTION_H(Float, float) +HS_OPTION_H(Double, double) +HS_OPTION_H(String, HsString) +HS_OPTION_H(StringView, HsStringPiece) +HS_OPTION_H(HsJSON, HsJSON) diff --git a/cpp/HsStructDefines.h b/cpp/HsStructDefines.h new file mode 100644 --- /dev/null +++ b/cpp/HsStructDefines.h @@ -0,0 +1,15 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#ifdef __HSC2HS__ +#define HS_STRUCT struct +#else +#define HS_STRUCT class +#endif diff --git a/cpp/HsVariant.h b/cpp/HsVariant.h new file mode 100644 --- /dev/null +++ b/cpp/HsVariant.h @@ -0,0 +1,343 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include "cpp/HsStruct.h" + +#include +#include + +struct HsVariant { + using VariantType = HsJSON; + using MapType = HsObject; + using MapKeyType = HsString; + using MapIterator = MapType::ConstIterator; + using VectorType = HsArray; + using VectorIterator = VectorType::ConstIterator; + using SetType = HsArray; + using SetIterator = SetType::ConstIterator; + using StringType = HsString; + using Type = facebook::serialize::Type; + using StructHandle = int; + + /** + * \defgroup as_type variant accessors + * @{ + */ + static Type type(const VariantType& obj) { + switch (obj.getType()) { + case HsJSON::Type::Null: + return Type::NULLT; + case HsJSON::Type::Bool: + return Type::BOOL; + case HsJSON::Type::Integral: + return Type::INT64; + case HsJSON::Type::Real: + return Type::DOUBLE; + case HsJSON::Type::String: + return Type::STRING; + case HsJSON::Type::Array: + return Type::VECTOR; + case HsJSON::Type::Object: + return Type::MAP; + default: + __builtin_unreachable(); + } + } + + static bool asBool(const VariantType& obj) { + return obj.asIntegral() != 0; + } + + static int64_t asInt64(const VariantType& obj) { + return obj.asIntegral(); + } + + static double asDouble(const VariantType& obj) { + return obj.asReal(); + } + + static const StringType& asString(const VariantType& obj) { + return obj.asString(); + } + + static const VectorType& asVector(const VariantType& obj) { + return obj.asArray(); + } + + static const MapType& asMap(const VariantType& obj) { + return obj.asObject(); + } + + static const SetType& asSet(const VariantType& obj) { + return obj.asArray(); + } + /** @} */ + + /** + * \defgroup to_variant variant creators + * @{ + */ + static VariantType createNull() { + return false; + } + static VariantType fromInt64(int64_t val) { + return val; + } + static VariantType fromBool(bool val) { + return val; + } + static VariantType fromDouble(double val) { + return val; + } + static VariantType fromString(StringType&& str) { + return std::move(str); + } + static VariantType fromMap(MapType&& map) { + return std::move(map); + } + static VariantType fromVector(VectorType&& vec) { + return std::move(vec); + } + static VariantType fromSet(SetType&& set) { + return std::move(set); + } + /** @} */ + + /** + * \defgroup map map methods + * @{ + */ + // builders + static MapType createMap() { + return MapType(); + } + + static MapType createMap(MapType&& m) { + return MapType(std::move(m)); + } + + static MapType reserveMap(size_t n) { + MapType ret; + ret.reserve(n); + return ret; + } + + static MapType reserveMap(StructHandle, size_t n) { + return reserveMap(n); + } + + static MapType getStaticEmptyMap() { + return createMap(); + } + + static MapKeyType mapKeyFromInt64(int64_t key) { + return HsString(folly::to(key)); + } + + static void mapSet(MapType& map, HsString&& key, VariantType&& value) { + map.add(std::move(key), std::move(value)); + } + + static void mapSet(MapType& map, const HsString& key, VariantType&& value) { + map.add(key, std::move(value)); + } + + static void mapSet(MapType& map, int64_t key, VariantType&& value) { + map.add(mapKeyFromInt64(key), std::move(value)); + } + + template + static void + mapSet(MapType& map, size_t /*idx*/, T&& key, VariantType&& value) { + mapSet(map, std::forward(key), std::move(value)); + } + + // accessors + static Type mapKeyType(const MapKeyType& /*map*/) { + return Type::STRING; + } + + static int64_t mapKeyAsInt64(const MapKeyType& /*key*/) { + throw std::runtime_error("mapKeyType should always be Type::STRING"); + } + + static HsString mapKeyAsString(const MapKeyType& key) { + return key; + } + + static MapIterator mapIterator(const MapType& map) { + return map.getIterator(); + } + + static bool mapNotEnd(const MapType& /*map*/, const MapIterator& it) { + return it.isValid(); + } + + static void mapNext(MapIterator& it) { + it.next(); + } + + static const HsString& mapKey(const MapIterator& it) { + return it.getKey(); + } + + static const HsJSON& mapValue(const MapIterator& it) { + return it.getValue(); + } + + /** @} */ + + /** + * \defgroup vector vector methods + * @{ + */ + // builders + static VectorType createVector() { + return VectorType(); + } + + static VectorType createVector(size_t size) { + auto vec = VectorType(); + vec.reserve(size); + return vec; + } + + static int64_t vectorSize(const VectorType& vec) { + return vec.size(); + } + + static void vectorAppend(VectorType& vec, VariantType&& v) { + vec.add(std::move(v)); + } + + // accessors + static VectorIterator vectorIterator(const VectorType& vec) { + return vec.begin(); + } + + static bool vectorNotEnd(const VectorType& vec, VectorIterator& it) { + return it != vec.end(); + } + + static void vectorNext(VectorIterator& it) { + ++it; + } + + static const VariantType& vectorValue(VectorIterator& it) { + return *it; + } + /** @} */ + + /** + * \defgroup set set methods + * @{ + */ + // builders + static SetType createSet() { + return SetType(); + } + + static SetType createSet(size_t size) { + auto set = SetType(); + set.reserve(size); + return set; + } + + static int64_t setSize(const SetType& set) { + return set.size(); + } + + static void setAppend(SetType& set, VariantType&& v) { + set.add(std::move(v)); + } + + // accessors + static SetIterator setIterator(const SetType& set) { + return set.begin(); + } + + static bool setNotEnd(const SetType& set, SetIterator& it) { + return it != set.end(); + } + + static void setNext(SetIterator& it) { + ++it; + } + + static const VariantType& setValue(SetIterator& it) { + return *it; + } + /** @} */ + + /** + * \defgroup string string methods + * @{ + */ + static StringType createString() { + return std::string(); + } + + static StringType createMutableString(size_t n) { + return std::string(n, '\0'); + } + + static char* getMutablePtr(StringType& str) { + return str.mutable_data(); + } + + static void shrinkString(StringType& str, size_t n) { + str.resize(n); + } + + static StringType stringFromData(const char* src, int n) { + return std::string(src, n); + } + + static StringType stringFromMutableString(StringType&& s) { + return std::move(s); + } + + static StringType createStaticString(const char* src, int n) { + return stringFromData(src, n); + } + + static StringType getStaticEmptyString() { + return std::string(); + } + + static void stringClear(StringType& str) { + str.clear(); + } + + static int stringLen(const StringType& str) { + return str.size(); + } + + static const char* stringData(const StringType& str) { + return str.data(); + } + + static void stringAppend(StringType& str, const char* src, int n) { + str.append(src, n); + } + + static void stringAppend(StringType& str, const StringType& src) { + str.append(src); + } + + static void traceSerialization(const VariantType&) {} + + static StructHandle registerStruct( + const StringType& stableIdentifier, + const std::vector>& fields) { + return -1; + } + /** @} */ +}; diff --git a/cpp/IOBuf.cpp b/cpp/IOBuf.cpp new file mode 100644 --- /dev/null +++ b/cpp/IOBuf.cpp @@ -0,0 +1,36 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include + +std::unique_ptr common::hs::newIOBufWrapping(HS_IOBuf* hs_iobuf) { + auto ioBuf = folly::IOBuf::wrapBuffer( + hs_iobuf->str_arr[hs_iobuf->len - 1], + hs_iobuf->len_arr[hs_iobuf->len - 1]); + for (int i = hs_iobuf->len - 2; i >= 0; i--) { + auto last = std::move(ioBuf); + ioBuf = + folly::IOBuf::wrapBuffer(hs_iobuf->str_arr[i], hs_iobuf->len_arr[i]); + ioBuf->appendChain(std::move(last)); + } + + return ioBuf; +} + +extern "C" { + +void get_iobuf_data(IOBuf* iobuf, IOBufData* iobuf_data) { + iobuf_data->length_ = iobuf->length(); + iobuf_data->data_buf_ = iobuf->data(); + iobuf_data->next_ = iobuf->pop().release(); +} + +void destroy_iobuf(IOBuf* iobuf, uint8_t* /* buffer */) { + delete iobuf; +} +} diff --git a/cpp/IOBuf.h b/cpp/IOBuf.h new file mode 100644 --- /dev/null +++ b/cpp/IOBuf.h @@ -0,0 +1,41 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include + +extern "C" { + +struct HS_IOBuf { + uint8_t** str_arr; + size_t* len_arr; + size_t len; +}; + +using folly::IOBuf; + +struct IOBufData { + int length_; + const uint8_t* data_buf_; + IOBuf* next_; +}; + +void get_iobuf_data(IOBuf* iobuf, IOBufData* iobuf_data); + +void destroy_iobuf(IOBuf* iobuf, uint8_t* buffer); + +} // extern "C" + +namespace common { +namespace hs { + +std::unique_ptr newIOBufWrapping(HS_IOBuf* hs_iobuf); + +} // namespace hs +} // namespace common diff --git a/cpp/Marshallable.h b/cpp/Marshallable.h new file mode 100644 --- /dev/null +++ b/cpp/Marshallable.h @@ -0,0 +1,17 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once +#include "cpp/Constructible.h" +#include "cpp/Destructible.h" + +#ifndef HS_DEFINE_MARSHALLABLE +#define HS_DEFINE_MARSHALLABLE(Name, Type...) \ + HS_DEFINE_DEFAULT_CONSTRUCTIBLE(Name, Type) \ + HS_DEFINE_DESTRUCTIBLE(Name, Type) +#endif diff --git a/cpp/RequestContext.h b/cpp/RequestContext.h new file mode 100644 --- /dev/null +++ b/cpp/RequestContext.h @@ -0,0 +1,51 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include +#include +#include + +// The address of folly::RequestContext should be constant and nonnull. +// The content of folly::RequestContext may be changed. +using RequestContextPtr = const std::shared_ptr; + +namespace facebook::common::hs { + +/** + * In a foreign function call from Haskell to C++, the caller can pass an + * explicit RequestContext (nonnull RequestContextPtr) or + * Maybe RequestContext (nullable RequestContextPtr). + * The C++ implementation should construct a \c RequestContextPtrScopeGuard + * at the entry point to ensure the correct implicit \c folly::RequestContext + * is always used in C++. There is usually no need to extend the lifetime of + * this scope guard beyond the foreign function itself as long as all + * async executions scheduled by it use async frameworks which are + * RequestContext aware, e.g. folly futures and fibers. + */ +class RequestContextPtrScopeGuard { + public: + explicit RequestContextPtrScopeGuard(RequestContextPtr* rc) { + if (rc != nullptr) { + guard_.emplace(*rc); + } + } + + RequestContextPtrScopeGuard(const RequestContextPtrScopeGuard&) = delete; + RequestContextPtrScopeGuard(RequestContextPtrScopeGuard&&) = delete; + RequestContextPtrScopeGuard& operator=(const RequestContextPtrScopeGuard&) = + delete; + RequestContextPtrScopeGuard& operator=(RequestContextPtrScopeGuard&&) = + delete; + + private: + std::optional guard_; +}; + +} // namespace facebook::common::hs diff --git a/cpp/cdynamic.cpp b/cpp/cdynamic.cpp new file mode 100644 --- /dev/null +++ b/cpp/cdynamic.cpp @@ -0,0 +1,193 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include "cpp/cdynamic.h" + +#include +#include +#include +#include "cpp/Destructible.h" + +using namespace folly; + +namespace facebook { +namespace hs { + +/** + * Read the type and value of a dynamic. If the dynamic is array or object, + * its size is returned as the value. + */ +void readDynamic(const dynamic* d, DType* ty, DValue* val) noexcept { + switch (d->type()) { + case dynamic::STRING: + *ty = tString; + val->string = d->c_str(); + break; + case dynamic::BOOL: + *ty = tBool; + val->boolean = d->asBool(); + break; + case dynamic::DOUBLE: + *ty = tDouble; + val->doubl = d->asDouble(); + break; + case dynamic::INT64: + *ty = tInt64; + val->int64 = d->asInt(); + break; + case dynamic::ARRAY: + *ty = tArray; + val->size = d->size(); + break; + case dynamic::OBJECT: + *ty = tObject; + val->size = d->size(); + break; + case dynamic::NULLT: + *ty = tNull; + val->null = nullptr; + break; + } +} + +/** + * Read the fields of a dynamic array. Memory for the array is + * allocated by the caller. The size of the array to allocate is + * returned by readDynamic(). + */ +int readDynamicArray( + const dynamic* d, + size_t /*size*/, + const dynamic** elems) noexcept { + if ((*d).type() != dynamic::ARRAY) + return 0; + + int i = 0; + for (const auto& e : *d) { + elems[i++] = &e; + } + return i; +} + +/** + * Read the fields of a dynamic object. Memory for the arrays are + * allocated by the caller. The size of the arrays to allocate is + * returned by readDynamic(). + */ +int readDynamicObject( + const dynamic* d, + size_t /*size*/, + const dynamic** keys, + const dynamic** vals) noexcept { + if ((*d).type() != dynamic::OBJECT) + return 0; + + // Relying on the iterator referring to elements by reference here. + auto it = (*d).items(); + int i = 0; + for (auto j = it.begin(); j != it.end(); ++j, ++i) { + keys[i] = &(j->first); + vals[i] = &(j->second); + } + return i; +} + +/** + * Create a dynamic with nullptr, boolean, double or const char*. + * It's caller's responsibility to allocate and free the memory. + */ +void createDynamic(dynamic* ret, DType ty, DValue* val) noexcept { + switch (static_cast(ty)) { + case dynamic::NULLT: + new (ret) dynamic(nullptr); + break; + case dynamic::BOOL: + new (ret) dynamic(val->boolean != 0); + break; + case dynamic::INT64: + new (ret) dynamic(val->int64); + break; + case dynamic::DOUBLE: + new (ret) dynamic(val->doubl); + break; + case dynamic::STRING: + new (ret) dynamic(val->string); + break; + case dynamic::ARRAY: + folly::terminate_with( + "call writeDynamicArray for dynamic::ARRAY"); + case dynamic::OBJECT: + folly::terminate_with( + "call writeDynamicObject for dynamic::OBJECT"); + default: + __builtin_unreachable(); + } +} + +/** + * Create a dynamic array with given \p elems. + * It's caller's responsibility to allocate and free the memory for \p ret. The + * elements of \p elems are invalidated. + */ +void createDynamicArray(dynamic* ret, size_t size, dynamic* elems) noexcept { + new (ret) dynamic(dynamic::array); + ret->resize(size); + for (size_t i = 0; i < size; ++i) { + ret->at(i) = std::move(elems[i]); + elems[i].~dynamic(); + } +} + +/** + * Create a dynamic array with given \p keys and \p vals. + * It's caller's responsibility to allocate and free the memory for \p ret. The + * elements of \p vals are invalidated. + */ +void createDynamicObject( + dynamic* ret, + size_t size, + const char** keys, + dynamic* vals) noexcept { + new (ret) dynamic(dynamic::object); + for (size_t i = 0; i < size; ++i) { + ret->insert(keys[i], std::move(vals[i])); + vals[i].~dynamic(); + } +} + +/** + * parse JSON using folly::parseJson() + * Returns either + * - a pointer to the folly::dynamic representing the parsed JSON. The caller + * owns this and is responsible for freeing it. + * - nullptr, and *err points to an error message. The caller owns the + * memory for the error message, and is responsible for freeing it. + */ +const folly::dynamic* parseJSON( + const char* str, + int64_t len, + int recursion_limit, + char** err) noexcept { + json::serialization_opts opts; + if (recursion_limit != -1) { + opts.recursion_limit = recursion_limit; + } + + try { + auto d = parseJson(folly::StringPiece(str, len), opts); + return new folly::dynamic(std::move(d)); + } catch (const std::exception& e) { + *err = strdup(e.what()); + return nullptr; + } +} + +} // namespace hs +} // namespace facebook + +HS_DEFINE_DESTRUCTIBLE(Dynamic, Dynamic) diff --git a/cpp/cdynamic.h b/cpp/cdynamic.h new file mode 100644 --- /dev/null +++ b/cpp/cdynamic.h @@ -0,0 +1,53 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include + +using Dynamic = folly::dynamic; + +enum DType { tNull, tArray, tBool, tDouble, tInt64, tObject, tString }; + +union DValue { + void* null; + int boolean; + size_t size; /* array, object */ + double doubl; + int64_t int64; + const char* string; +}; + +namespace facebook { +namespace hs { + +void readDynamic(const Dynamic* d, DType* ty, DValue* val) noexcept; + +int readDynamicArray( + const Dynamic* d, + size_t size, + const Dynamic** elems) noexcept; +int readDynamicObject( + const Dynamic* d, + size_t size, + const Dynamic** keys, + const Dynamic** vals) noexcept; + +void createDynamic(Dynamic* ret, DType ty, DValue* val) noexcept; +void createDynamicArray(Dynamic* ret, size_t size, Dynamic* elems) noexcept; +void createDynamicObject( + Dynamic* ret, + size_t size, + const char** keys, + Dynamic* vals) noexcept; + +const folly::dynamic* +parseJSON(const char* str, int64_t len, char** err) noexcept; + +} // namespace hs +} // namespace facebook diff --git a/cpp/ffi.cpp b/cpp/ffi.cpp new file mode 100644 --- /dev/null +++ b/cpp/ffi.cpp @@ -0,0 +1,31 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include "cpp/ffi.h" +#include "cpp/wrap.h" + +namespace facebook { +namespace hs { +namespace ffi { + +const char* outOfMemory = "out of memory"; +const char* unknownError = "unknown error"; + +} // namespace ffi +} // namespace hs +} // namespace facebook + +extern "C" { + +void hs_ffi_free_error(const char* err) { + if (err != facebook::hs::ffi::outOfMemory && + err != facebook::hs::ffi::unknownError) { + std::free(const_cast(err)); + } +} +} diff --git a/cpp/ffi.h b/cpp/ffi.h new file mode 100644 --- /dev/null +++ b/cpp/ffi.h @@ -0,0 +1,19 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#ifdef __cplusplus +extern "C" { +#endif + +void hs_ffi_free_error(const char* error); + +#ifdef __cplusplus +} +#endif diff --git a/cpp/logging.cpp b/cpp/logging.cpp new file mode 100644 --- /dev/null +++ b/cpp/logging.cpp @@ -0,0 +1,49 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include "cpp/logging.h" +#include + +int vlog_is_on(int level) noexcept { + return VLOG_IS_ON(level); +} + +#define LOG_EXT(severity, file, line) \ + google::LogMessage(file, line, ::google::GLOG_##severity).stream() + +void glog_verbose(const char* file, int line, const char* msg) noexcept { +#ifdef GLOG_VERBOSE + LOG_EXT(VERBOSE, file, line) << msg; +#else + LOG_EXT(INFO, file, line) << msg; +#endif +} + +void glog_info(const char* file, int line, const char* msg) noexcept { + LOG_EXT(INFO, file, line) << msg; +} + +void glog_warning(const char* file, int line, const char* msg) noexcept { + LOG_EXT(WARNING, file, line) << msg; +} + +void glog_error(const char* file, int line, const char* msg) noexcept { + LOG_EXT(ERROR, file, line) << msg; +} + +void glog_fatal(const char* file, int line, const char* msg) noexcept { + LOG_EXT(FATAL, file, line) << msg; +} + +void glog_flush() noexcept { +#ifdef GLOG_VERBOSE + google::FlushLogFiles(google::GLOG_VERBOSE); +#else + google::FlushLogFiles(google::GLOG_INFO); +#endif +} diff --git a/cpp/logging.h b/cpp/logging.h new file mode 100644 --- /dev/null +++ b/cpp/logging.h @@ -0,0 +1,17 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +int vlog_is_on(int level) noexcept; + +void glog_verbose(const char* file, int line, const char* msg) noexcept; +void glog_info(const char* file, int line, const char* msg) noexcept; +void glog_warning(const char* file, int line, const char* msg) noexcept; +void glog_error(const char* file, int line, const char* msg) noexcept; +void glog_fatal(const char* file, int line, const char* msg) noexcept; diff --git a/cpp/memory.h b/cpp/memory.h new file mode 100644 --- /dev/null +++ b/cpp/memory.h @@ -0,0 +1,115 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include +#include +#include + +namespace facebook { +namespace hs { +namespace ffi { + +/// A wrapper for a malloc'ed block of memory. Ownership can be release via +/// 'release' and 'release_to'; the memory must then be released manually via +/// 'free'. This makes it suitable for passing to Haskell. +template +struct malloced_array { + static_assert( + std::is_trivially_destructible::value, + "malloced_array requires a trivially destructible type"); + + malloced_array() noexcept : n(0) {} + explicit malloced_array(size_t k) + : ptr(folly::allocate_sys_buffer(k * sizeof(T))), n(k) {} + malloced_array(folly::SysBufferUniquePtr&& p, size_t k) noexcept + : ptr(std::move(p)), n(k) {} + malloced_array(malloced_array&&) noexcept = default; + malloced_array(const malloced_array&) = delete; + + malloced_array& operator=(malloced_array&& other) noexcept = default; + malloced_array& operator=(const malloced_array&) = delete; + + template + void release_to(U** data, size_t* size) noexcept { + *size = n; + *data = release(); + } + + T* release() noexcept { + n = 0; + return static_cast(ptr.release()); + } + + T* get() const noexcept { + return static_cast(ptr.get()); + } + size_t size() const noexcept { + return n; + } + + T& operator[](size_t i) const noexcept { + return get()[i]; + } + + void prune(size_t k) noexcept { + assert(k <= n); + n = k; + } + + private: + folly::SysBufferUniquePtr ptr; + size_t n; +}; + +template +malloced_array malloc_array(size_t n) { + return malloced_array(n); +} + +template +malloced_array clone_array(const T* data, size_t size, size_t pad = 0) { + malloced_array arr(size + pad); + if (size != 0) { + std::memcpy(arr.get(), data, size * sizeof(T)); + } + return arr; +} + +inline malloced_array +clone_bytes(const void* data, size_t size, size_t pad = 0) { + return clone_array(static_cast(data), size, pad); +} + +inline malloced_array clone_bytes( + folly::ByteRange bytes, + size_t pad = 0) { + return clone_bytes(bytes.data(), bytes.size(), pad); +} + +inline malloced_array clone_bytes( + const folly::fbstring& bytes, + size_t pad = 0) { + return clone_bytes(bytes.data(), bytes.size(), pad); +} + +inline malloced_array clone_bytes( + const std::string& bytes, + size_t pad = 0) { + return clone_bytes(bytes.data(), bytes.size(), pad); +} + +inline malloced_array clone_string(const std::string& s, size_t pad = 0) { + auto p = s.c_str(); + return clone_array(p, strlen(p) + 1, pad); +} + +} // namespace ffi +} // namespace hs +} // namespace facebook diff --git a/cpp/wrap.h b/cpp/wrap.h new file mode 100644 --- /dev/null +++ b/cpp/wrap.h @@ -0,0 +1,49 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include +#include + +namespace facebook { +namespace hs { +namespace ffi { + +extern const char* outOfMemory; +extern const char* unknownError; + +template +const char* wrap(F&& f) noexcept { + try { + f(); + return nullptr; + } catch (const std::exception& e) { + const char* s = strdup(e.what()); + return s == nullptr ? outOfMemory : s; + } catch (...) { + return unknownError; + } +} + +template +void wrap_(F&& f) noexcept { + try { + f(); + } catch (...) { + } +} + +template +void free_(T* obj) noexcept { + wrap_([=] { delete obj; }); +} + +} // namespace ffi +} // namespace hs +} // namespace facebook diff --git a/fb-util.cabal b/fb-util.cabal new file mode 100644 --- /dev/null +++ b/fb-util.cabal @@ -0,0 +1,481 @@ +cabal-version: 3.6 + +-- Copyright (c) Facebook, Inc. and its affiliates. + +name: fb-util +version: 0.1.0.1 +synopsis: Various utility libraries +homepage: https://github.com/facebookincubator/hsthrift +bug-reports: https://github.com/facebookincubator/hsthrift/issues +license: BSD-3-Clause +license-file: LICENSE +author: Facebook, Inc. +maintainer: hsthrift-team@fb.com +copyright: (c) Facebook, All Rights Reserved +category: Utilities +build-type: Simple +extra-source-files: cpp/*.h, + tests/DynamicHelper.h, + tests/HsStructHelper.h, + hsc.h +extra-doc-files: CHANGELOG.md + +description: + Utility libraries used by Meta projects, notably hsthrift and Glean. + + NOTE: for build instructions, see + + +source-repository head + type: git + location: https://github.com/facebookincubator/hsthrift.git + +common fb-haskell + default-language: Haskell2010 + default-extensions: + BangPatterns + BinaryLiterals + DataKinds + DeriveDataTypeable + DeriveGeneric + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + MultiWayIf + NoMonomorphismRestriction + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + NondecreasingIndentation + if flag(opt) + ghc-options: -O2 + +common fb-cpp + cxx-options: -std=c++17 + -- We use hsc2hs with C++ headers, so we need to compile the + -- generated code with g++. The hsc2hs-generated binary is linked + -- by ghc, because we depend on a Haskell package (mangle). + hsc2hs-options: --cc=g++ --lflag=-lstdc++ --cflag=-D__HSC2HS__=1 --cflag=-std=c++17 + if !flag(clang) + cxx-options: -fcoroutines + if arch(x86_64) + cxx-options: -march=haswell + if flag(opt) + cxx-options: -O3 + +flag opt + default: False + +flag clang + default: False + +-- Enable modules that depend on folly. Since folly normally needs to +-- be built from source, it is an inconvenient dependency. Without +-- folly we can still build thrift-compiler and the thrift-http +-- transport; only thrift-cpp-channel requires folly. +-- +-- Ideally we'd split fb-util into two (or more) packages, or +-- sub-libraries. But that requires moving files around because the +-- Haskell sources would need to be in distinct directories, which needs +-- to be done in the upstream repository. +flag folly + default: False + +library + import: fb-haskell, fb-cpp + + exposed-modules: + Compat.Prettyprinter + Compat.Prettyprinter.Util + Compat.Prettyprinter.Render.Text + Control.Concurrent.Stream + Control.Trace + Control.Trace.Core + Control.Trace.VLog + Data.MovingAverageRateLimiter + Data.RateLimiterMap + Util.ASan + Util.Async + Util.Aeson + Util.AllocLimit + Util.Applicative + Util.Bag + Util.Binary.Parser + Util.Bits + Util.Buffer + Util.Build + Util.ByteString + Util.Concurrent + Util.Control.Exception + Util.Control.Exception.CallStack + Util.Control.Monad + Util.Defer + -- Util.Dll + Util.Encoding + Util.Err + Util.Fd + Util.FFI + Util.FilePath + Util.Function + Util.Graph + -- Util.GFlags + Util.HSE + Util.HUnit + Util.HashMap.Strict + Util.IO + Util.JSON.Pretty + Util.Lens + Util.Linter + Util.List + Util.List.HigherOrder + Util.Log + Util.Log.Text + Util.Log.Internal + Util.Log.String + Util.LogIfSlow + Util.Logger + Util.MD5 + Util.Memory + Util.Monoid + Util.Network + Util.OptParse + Util.Predicate + Util.PrettyPrint + Util.RWVar + Util.Reader + Util.STM + Util.Show + Util.String + Util.String.Quasi + Util.Testing + Util.Text + Util.Time + Util.TimeSec + Util.Timing + Util.ToExp + Util.Typeable + Util.WBVar + + cxx-sources: + cpp/ffi.cpp + cpp/logging.cpp + Util/AsanAlloc.cpp + -- Util/GFlags.cpp + + install-includes: + cpp/ffi.h + cpp/memory.h + cpp/wrap.h + Util/AsanAlloc.h + + include-dirs: . + hs-source-dirs: . + + build-depends: + HUnit ^>= 1.6.1, + QuickCheck >= 2.14.3 && < 2.15, + aeson < 2.3, + aeson-pretty >= 0.8.10 && < 0.9, + array ^>=0.5.2.0, + async ^>=2.2.1, + atomic-primops >= 0.8.8 && < 0.9, + attoparsec >= 0.14.4 && < 0.15, + attoparsec-aeson >= 2.1 && < 2.3, + base >=4.11.1.0 && <4.20, + binary ^>=0.8.5.1, + bytestring >=0.10.8.2 && <0.13, + bytestring-lexing >= 0.5.0 && < 0.6, + clock >= 0.8.4 && < 0.9, + concurrent-extra >= 0.7.0 && < 0.8, + containers >=0.5.11 && <0.7, + data-default >= 0.8.0 && < 0.9, + deepseq >= 1.4.4 && < 1.6, + directory ^>=1.3.1.5, + either >= 5.0.2 && < 5.1, + exceptions >= 0.10.4 && < 0.11, + extra >= 1.8 && < 1.9, + filepath ^>=1.4.2, + ghc >= 8.6.5 && < 9.9, + ghci >=8.6.5 && < 9.9, + hashable >=1.2.7.0 && <1.5, + haskell-src-exts >= 1.23.1 && < 1.24, + integer-gmp >=1.0.2.0 && <1.2, + json >= 0.11 && < 0.12, + lens >= 5.3.3 && < 5.4, + lifted-base >= 0.2.3 && < 0.3, + mangle >= 0.1.0 && < 0.2, + monad-control >= 1.0.3 && < 1.1, + mtl >= 2.2.2 && < 2.4, + optparse-applicative >= 0.17 && < 0.19, + pretty ^>=1.1.3.6, + prettyprinter >=1.2.1 && <1.8, + primitive < 0.9, + process ^>=1.6.3.0, + scientific >= 0.3.7 && < 0.4, + some >= 1.0.6 && < 1.1, + split ^>=0.2.3.3, + stm >= 2.5.0 && < 2.6, + template-haskell >=2.13 && <2.22, + text ^>=1.2.3.0, + text-show >= 3.10.5 && < 3.12, + time >=1.8.0.2 && <1.13, + transformers >= 0.5.6 && < 0.7, + unix >= 2.7.2.2 && < 2.9, + unordered-containers ^>=0.2.9.0, + vector >=0.12.0.1 && <0.14, + + build-tool-depends: hsc2hs:hsc2hs + + pkgconfig-depends: libglog, libevent, fmt, gflags + if flag(folly) + extra-libraries: double-conversion + else + pkgconfig-depends: double-conversion + + if flag(folly) + exposed-modules: + Foreign.CPP.Addressable + Foreign.CPP.HsStruct + Foreign.CPP.HsStruct.HsArray + Foreign.CPP.HsStruct.HsOption + Foreign.CPP.HsStruct.HsSet + Foreign.CPP.HsStruct.HsStdTuple + Foreign.CPP.HsStruct.HsMap + Foreign.CPP.HsStruct.HsStdVariant + Foreign.CPP.HsStruct.Unsafe + Foreign.CPP.HsStruct.Types + Foreign.CPP.HsStruct.Utils + Foreign.CPP.Marshallable + Foreign.CPP.Marshallable.TH + Foreign.CPP.Dynamic + Util.EventBase + Util.Executor + Util.IOBuf + + install-includes: + cpp/HsOption.h + cpp/HsStdTuple.h + cpp/HsStdVariant.h + cpp/HsStruct.h + cpp/HsStructDefines.h + + cxx-sources: + cpp/HsStruct.cpp + cpp/cdynamic.cpp + cpp/EventBaseDataplane.cpp + cpp/Executor.cpp + cpp/HsStruct.cpp + cpp/IOBuf.cpp + + pkgconfig-depends: libfolly + +common test-common + extra-libraries: stdc++ + ghc-options: -threaded + hs-source-dirs: tests, tests/github + other-modules: SpecRunner + build-depends: base, + aeson, + async, + binary, + bytestring, + containers, + directory, + fb-util, + fb-stubs, + filepath, + hspec, + hspec-contrib, + HUnit ^>= 1.6.1, + json, + lens, + mtl, + optparse-applicative, + prettyprinter, + QuickCheck, + regex-base, + regex-pcre, + scientific, + template-haskell, + temporary, + text, + text-show, + transformers, + unordered-containers, + vector + + build-tool-depends: hsc2hs:hsc2hs + + -- We use hsc2hs with C++ headers, so we need to compile the + -- generated code with g++. The hsc2hs-generated binary is linked + -- by ghc. + hsc2hs-options: --cc=g++ --lflag=-lstdc++ --cflag=-D__HSC2HS__=1 --cflag=-std=c++17 + + +test-suite stream + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: StreamTest.hs + ghc-options: -main-is StreamTest +test-suite movavgrl + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: MovingAverageRateLimiterTest.hs + ghc-options: -main-is MovingAverageRateLimiterTest +test-suite rlmap + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: RateLimiterMapTest.hs + ghc-options: -main-is RateLimiterMapTest +test-suite iobuf + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: IOBufTest.hs + ghc-options: -main-is IOBufTest + cxx-sources: tests/IOBufTest.cpp + if !flag(folly) + buildable: False +test-suite alloc-limit + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: AllocLimitTest.hs + ghc-options: -main-is AllocLimitTest +test-suite unit-tests + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: UnitTests.hs + ghc-options: -main-is UnitTests +test-suite rwvar + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: RWVarTest.hs + ghc-options: -main-is RWVarTest +test-suite th + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: THTest.hs + ghc-options: -main-is THTest +test-suite filepath + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: FilePathTest.hs + ghc-options: -main-is FilePathTest +test-suite optparse + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: OptParseTest.hs + ghc-options: -main-is OptParseTest +test-suite lens + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: LensTest.hs + ghc-options: -main-is LensTest +test-suite toexp + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: ToExpTest.hs + ghc-options: -main-is ToExpTest +test-suite aeson + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: AesonTest.hs + ghc-options: -main-is AesonTest +test-suite buffer + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: BufferTest.hs + ghc-options: -main-is BufferTest +test-suite exception + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: ExceptionTest.hs + ghc-options: -main-is ExceptionTest + if !flag(folly) + buildable: False +test-suite control-exception + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: ControlExceptionTest.hs + ghc-options: -main-is ControlExceptionTest +test-suite json-pretty + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: JSONPrettyTest.hs + ghc-options: -main-is JSONPrettyTest +test-suite io + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: IOTest.hs + ghc-options: -main-is IOTest +test-suite time-sec + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: TimeSecTest.hs + ghc-options: -main-is TimeSecTest +test-suite list + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: ListTest.hs + ghc-options: -main-is ListTest +test-suite graph + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: GraphTest.hs + ghc-options: -main-is GraphTest +test-suite concurrent + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: ConcurrentTest.hs + ghc-options: -main-is ConcurrentTest +test-suite md5 + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: MD5Test.hs + ghc-options: -main-is MD5Test +test-suite control-monad + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: Control/MonadTest.hs + ghc-options: -main-is Control.MonadTest +test-suite string-quasi + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: StringQuasiTest.hs + ghc-options: -main-is StringQuasiTest +test-suite dynamic + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: DynamicTest.hs + cxx-sources: tests/DynamicHelper.cpp + ghc-options: -main-is DynamicTest + if !flag(folly) + buildable: False +test-suite test-hs-struct + import: fb-haskell, fb-cpp, test-common + type: exitcode-stdio-1.0 + main-is: HsStructTest.hs + other-modules: HsStructTestTypes + cxx-sources: tests/HsStructHelper.cpp + ghc-options: -main-is HsStructTest + build-depends: extra + if !flag(folly) + buildable: False + +-- TODO: commented out because of a linker problem +-- test-suite gflags +-- import: fb-haskell, fb-cpp, test-common +-- type: exitcode-stdio-1.0 +-- main-is: GFlagsTest.hs +-- ghc-options: -main-is GFlagsTest +-- cxx-sources: tests/GFlagsTest.cpp diff --git a/hsc.h b/hsc.h new file mode 100644 --- /dev/null +++ b/hsc.h @@ -0,0 +1,60 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include + +#include +#include +#include + +/* + * Utilities for use with hsc2hs. + */ + +/* + * #{ alignment T } + * + * Produces the minimal alignment of a data type. + * NOTE: we can't use the macro that comes with hsc2hs, because + * it doesn't build clearly under clang. TODO(14913295): upstream this + */ +#undef hsc_alignment +#define hsc_alignment(x...) \ + do { \ + struct __anon_x__ { \ + char a; \ + x b; \ + }; \ + hsc_printf("%lu", (unsigned long)offsetof(struct __anon_x__, b)); \ + } while (0) + +/* + * #{ verbatim C++ code } + * + * Inserts any C++ code as it is in the code generator. An example use + * case can be: #{ verbatim using namespace facebook::nodeapi; } + */ +#undef hsc_verbatim +#define hsc_verbatim(...) __VA_ARGS__ + +extern "C" HsPtr itaniumMangle(HsPtr a1, size_t l); + +#define hsc_print_args(n) \ + for (int i = 0; i < n; i++) { \ + hsc_printf("x%d ", i); \ + } + +#define hsc_check_unsafe_wrapper(f, n, sig) \ + hsc_printf("%s_ %s\n", #f, #sig); \ + hsc_printf("%s %s\n", #f, #sig); \ + hsc_printf("%s ", #f); \ + hsc_print_args(n); \ + hsc_printf("= checkUnsafe \"%s\" $ %s_ ", #f, #f); \ + hsc_print_args(n) hsc_printf("\n"); diff --git a/tests/AesonTest.hs b/tests/AesonTest.hs new file mode 100644 --- /dev/null +++ b/tests/AesonTest.hs @@ -0,0 +1,32 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module AesonTest (main) where + +import Test.HUnit +import TestRunner + +import Data.Aeson hiding (decode) +import Data.Char +import qualified Data.Text as Text + +import Util.Aeson + +utf16SurrogatesTest :: Test +utf16SurrogatesTest = TestLabel "UTF-16 surrogates" . TestCase $ do + assertEqual "U+FFFF" (Just $ pack [0xFFFF]) (decode "\"\\uffff\"") + assertEqual "U+24B62" (Just $ pack [0x24B62]) (decode "\"\\uD852\\uDF62\"") + assertEqual "Invalid" (Nothing :: Maybe Value) (decode "\"\\uDF62\\uD852\"") + where + pack = String . Text.pack . map chr + decode = either (const Nothing) Just . parseValueStrict + +main :: IO () +main = testRunner $ TestList + [ utf16SurrogatesTest + ] diff --git a/tests/AllocLimitTest.hs b/tests/AllocLimitTest.hs new file mode 100644 --- /dev/null +++ b/tests/AllocLimitTest.hs @@ -0,0 +1,47 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE MagicHash #-} +module AllocLimitTest (main) where + +import Test.HUnit +import TestRunner + +import Util.AllocLimit + +import Control.Exception +import GHC.Conc +import GHC.Exts + +-- Test that GHC throws an alloc limit exception on code that *only* +-- allocates stack and not heap. +allocLimitStackTest :: Test +allocLimitStackTest = TestLabel "allocLimitStackTest" $ TestCase $ do + let f :: Int# -> Int# + f x = if isTrue# (x <# 0#) -- avoid optimising away x + then 1# + else f (x +# 1#) -# 1# -- should just grow the stack + + setAllocationCounter (10*1024*1024) + enableAllocationLimit + r <- try $ evaluate (isTrue# (f 0# ==# 0#)) + disableAllocationLimit + assertBool "allocLimitTest" $ case r of + Left e | Just AllocationLimitExceeded <- fromException e -> True + _ -> False + +limitAllocsTest :: Test +limitAllocsTest = TestLabel "limitAllocs" $ TestCase $ do + e <- limitAllocs 10000 $ evaluate $ sum [(1::Integer)..] + assertEqual "limitAllocs Nothing" Nothing e + +main :: IO () +main = testRunner $ TestList + [ allocLimitStackTest + , limitAllocsTest + ] diff --git a/tests/BufferTest.hs b/tests/BufferTest.hs new file mode 100644 --- /dev/null +++ b/tests/BufferTest.hs @@ -0,0 +1,75 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module BufferTest (main) where + +import Control.Monad.ST +import Control.Monad.ST.Unsafe +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import Data.Word (Word8) +import Foreign.Marshal.Utils +import Foreign.Ptr (castPtr) +import Test.HUnit +import Test.QuickCheck + +import Facebook.Init +import TestRunner +import Util.Testing + +import qualified Util.Buffer as Buffer + +data FillStep + = FillByte Word8 + | FillByteString ByteString + | FillAlloc Int ByteString + deriving(Show) + +stepToBS :: FillStep -> ByteString +stepToBS (FillByte x) = BS.singleton x +stepToBS (FillByteString x) = x +stepToBS (FillAlloc _ x) = x + +step :: FillStep -> Buffer.Fill s () +step (FillByte x) = Buffer.byte x +step (FillByteString x) = Buffer.byteString x +step (FillAlloc n x) = Buffer.alloc n $ \p -> unsafeIOToST $ + BS.unsafeUseAsCStringLen x $ \(q,k) -> do + copyBytes p (castPtr q) k + return k + +instance Arbitrary ByteString where + arbitrary = BS.pack <$> arbitrary + +instance Arbitrary FillStep where + arbitrary = oneof + [ FillByte <$> arbitrary + , FillByteString <$> arbitrary + , (\(NonNegative n) s -> FillAlloc (BS.length s + n) s) + <$> arbitrary + <*> arbitrary + ] + +prop_fillByteString :: NonEmptyList (NonEmptyList FillStep) -> Property +prop_fillByteString ss = + runST (Buffer.fillByteString 1 + $ foldr1 (\p q -> p >>= \_ -> q) + $ map (foldr1 (>>) . map step) stepss + ) + === + mconcat (map stepToBS $ concat stepss) + where + stepss = getNonEmpty <$> getNonEmpty ss + +main :: IO () +main = withFacebookUnitTest $ testRunner $ TestList + [ TestLabel "fillByteString" $ TestCase $ assertProperty "mismatch" + prop_fillByteString + ] diff --git a/tests/ConcurrentTest.hs b/tests/ConcurrentTest.hs new file mode 100644 --- /dev/null +++ b/tests/ConcurrentTest.hs @@ -0,0 +1,44 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module ConcurrentTest where + +import Control.Exception +import Data.IORef + +import Test.HUnit +import TestRunner + +import Util.Concurrent + +cacheSuccessTest :: Test +cacheSuccessTest = TestLabel "cacheSuccess" $ TestCase $ do + c <- cacheSuccess (return (3::Int)) + r <- c + assertEqual "cacheSuccess ok" r 3 + r <- c + assertEqual "cacheSuccess ok2" r 3 + x <- newIORef (0::Int) + c <- cacheSuccess (modifyIORef x (+1) >> readIORef x) + r <- c + assertEqual "cacheSuccess ok3" r 1 + r <- c + assertEqual "cacheSuccess ok4" r 1 + x <- newIORef (0::Int) + c <- cacheSuccess $ do + modifyIORef x (+1); z <- readIORef x; throwIO $ ErrorCall $ show z + r <- try c :: IO (Either ErrorCall ()) + assertEqual "cacheSuccess fail1" r (Left (ErrorCall "1")) + r <- try c :: IO (Either ErrorCall ()) + assertEqual "cacheSuccess fail2" r (Left (ErrorCall "2")) + +main :: IO () +main = testRunner $ TestList + [ cacheSuccessTest + ] diff --git a/tests/Control/MonadTest.hs b/tests/Control/MonadTest.hs new file mode 100644 --- /dev/null +++ b/tests/Control/MonadTest.hs @@ -0,0 +1,32 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module Control.MonadTest (main) where + +import Test.HUnit +import TestRunner + +import Facebook.Init +import Util.Control.Monad + +firstMLazyTest :: Test +firstMLazyTest = TestLabel "firstMLazy" . TestCase $ do + r <- firstMLazy [] + assertEqual "Nothing" Nothing (r :: Maybe Int) + + r <- firstMLazy + [ return Nothing + , return $ Just 1 + , return $ Just 2 + , error "notFound" + ] + assertEqual "Just" (Just 1) (r :: Maybe Int) + +main :: IO () +main = withFacebookUnitTest $ + testRunner firstMLazyTest diff --git a/tests/ControlExceptionTest.hs b/tests/ControlExceptionTest.hs new file mode 100644 --- /dev/null +++ b/tests/ControlExceptionTest.hs @@ -0,0 +1,35 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module ControlExceptionTest where + +import Control.Exception +import Util.Control.Exception + +import Test.HUnit +import TestRunner + +import Facebook.Init (withFacebookUnitTest) + +newtype MyException = MyException String deriving (Eq, Show) +instance Exception MyException + +main :: IO () +main = withFacebookUnitTest $ testRunner $ TestLabel "throwLeftIO" $ TestList + [ TestLabel "with left" $ TestCase $ do + let + ex = MyException "bad!" + (res :: Either MyException ()) <- try $ throwLeftIO $ Left ex + assertEqual "throws the exception" res (Left ex) + , TestLabel "with right" $ TestCase $ do + let + val = "good" + (res :: Either MyException String) <- try $ throwLeftIO + (Right val :: Either MyException String) + assertEqual "returns the value" res (Right val) + ] diff --git a/tests/DynamicHelper.cpp b/tests/DynamicHelper.cpp new file mode 100644 --- /dev/null +++ b/tests/DynamicHelper.cpp @@ -0,0 +1,64 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include "tests/DynamicHelper.h" + +#include + +const folly::dynamic* newDynamic() noexcept { + folly::dynamic* d = new folly::dynamic(folly::dynamic::object); + + d->insert("int", 42); + d->insert("string", "wibble"); + d->insert("double", 1000.0 / 1024.0); + d->insert("array", folly::dynamic::array(1, 2, 3)); + d->insert("null", nullptr); + d->insert("object", folly::dynamic::object("a", "b")); + d->insert("bool", true); + + return d; +} + +const HsJSON* newHsJSON() noexcept { + std::unique_ptr d(newDynamic()); + return new HsJSON(*d); +} + +static std::string buf; + +void initializeJson(const char* filename) noexcept { + std::ifstream fin(filename); + buf.assign( + std::istreambuf_iterator(fin), std::istreambuf_iterator()); +} + +const char* getJsonAsCStringLen(int64_t* len) noexcept { + *len = buf.size(); + return buf.data(); +} + +const folly::dynamic* getJsonAsPtrDynamic() noexcept { + auto d = parseJson(folly::StringPiece(buf.data(), buf.size())); + return new folly::dynamic(std::move(d)); +} + +const HsJSON* getJsonAsPtrHsJSON() noexcept { + auto d = parseJson(folly::StringPiece(buf.data(), buf.size())); + return new HsJSON(d); +} + +const folly::dynamic* parseJSON(const char* str, int64_t len) noexcept { + auto d = parseJson(folly::StringPiece(str, len)); + return new folly::dynamic(std::move(d)); +} + +int64_t compareDynamic( + const folly::dynamic* lhs, + const folly::dynamic* rhs) noexcept { + return *lhs == *rhs ? 1 : 0; +} diff --git a/tests/DynamicHelper.h b/tests/DynamicHelper.h new file mode 100644 --- /dev/null +++ b/tests/DynamicHelper.h @@ -0,0 +1,29 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include +#include "cpp/HsStruct.h" + +extern "C" { + +const folly::dynamic* newDynamic() noexcept; + +const HsJSON* newHsJSON() noexcept; + +void initializeJson(const char* filename) noexcept; +const char* getJsonAsCStringLen(int64_t* len) noexcept; +const folly::dynamic* getJsonAsPtrDynamic() noexcept; +const HsJSON* getJsonAsPtrHsJSON() noexcept; + +const folly::dynamic* parseJSON(const char* str, int64_t len) noexcept; +int64_t compareDynamic( + const folly::dynamic* lhs, + const folly::dynamic* rhs) noexcept; +} diff --git a/tests/DynamicTest.hs b/tests/DynamicTest.hs new file mode 100644 --- /dev/null +++ b/tests/DynamicTest.hs @@ -0,0 +1,90 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module DynamicTest (main) where + +import Control.Exception (bracket) +import Data.Aeson hiding (parseJSON) +import qualified Data.ByteString.Lazy as LB +import Data.Either +import Data.Text (Text) +import Foreign +import System.Timeout (timeout) +import Test.HUnit +import TestRunner + +import Foreign.CPP.Marshallable +import Foreign.CPP.Dynamic +import Foreign.CPP.HsStruct + +expectedJSON :: Value +expectedJSON = object + [ "int" .= (42::Int) + , "string" .= ("wibble" :: Text) + , "double" .= (1000.0 / 1024.0 :: Double) + , "array" .= [(1::Int)..3] + , "object" .= object ["a" .= ("b" :: Text)] + , "null" .= Null + , "bool" .= True + ] + +readDynamicTest :: Test +readDynamicTest = TestCase $ do + json <- bracket newDynamic delete readDynamic + assertEqual "readDynamicTest" expectedJSON json + +peekHsJSONTest :: Test +peekHsJSONTest = TestCase $ do + json <- bracket newHsJSON delete $ fmap hsJSON . peek + assertEqual "peekHsJSONTest" expectedJSON json + +withDynamicTest :: Test +withDynamicTest = TestCase $ do + json <- withDynamic expectedJSON readDynamic + assertEqual "withDynamicTest" expectedJSON json + +nestedValueTest :: Test +nestedValueTest = TestCase $ do + -- readDynamic should finish in linear time + Just json <- timeout 1000000 $ withDynamic nestedJSON readDynamic + assertEqual "nestedValueTest" nestedJSON json + where + nestedJSON = foldr ($!) (toJSON True) $ + take 5000 $ cycle [toArray, toObject] + toArray v = toJSON [v] + toObject v = object ["key" .= v] + +parseJSONTest :: Test +parseJSONTest = TestCase $ do + result <- parseJSON (LB.toStrict (encode expectedJSON)) + assertBool "parseJSON" $ + case result of + Left _ -> False + Right val -> val == expectedJSON + +parseJSONError :: Test +parseJSONError = TestCase $ do + result <- parseJSON "this is not JSON" + print result + assertBool "parseJSON" $ isLeft result + +main :: IO () +main = testRunner $ TestList $ map (uncurry TestLabel) + [ ("readDynamicTest", readDynamicTest) + , ("peekHsJSONTest", peekHsJSONTest) + , ("withDynamicTest", withDynamicTest) + , ("nestedValueTest", nestedValueTest) + , ("parseJSONTest", parseJSONTest) + , ("parseJSONError", parseJSONError) + ] + +foreign import ccall unsafe "newDynamic" + newDynamic :: IO (Ptr Dynamic) + +foreign import ccall unsafe "newHsJSON" + newHsJSON :: IO (Ptr HsJSON) diff --git a/tests/ExceptionTest.hs b/tests/ExceptionTest.hs new file mode 100644 --- /dev/null +++ b/tests/ExceptionTest.hs @@ -0,0 +1,93 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# OPTIONS_GHC -fno-warn-name-shadowing -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module ExceptionTest (main) where + +import Control.Exception +import Util.Control.Exception +import Test.HUnit +import TestRunner + +catchAllTest :: Test +catchAllTest = TestLabel "catchAll" . TestCase $ do + r <- (throwIO ThreadKilled `catchAll` \_ -> return 1) + `catch` \SomeException{} -> return (2::Int) + assertEqual "catchAll1" 2 r + r <- (throwIO (ErrorCall "x") `catchAll` \_ -> return 1) + `catch` \SomeException{} -> return (2::Int) + assertEqual "catchAll2" 1 r + +tryAllTest :: Test +tryAllTest = TestLabel "tryAll" . TestCase $ do + r <- try (tryAll (throwIO ThreadKilled)) + assertBool "tryAll1" $ case r of + Left x | Just ThreadKilled{} <- fromException x -> True + _ -> False + r <- try (tryAll (throwIO (ErrorCall "x"))) + :: IO (Either SomeException (Either SomeException Int)) + assertBool "tryAll2" $ case r of + Right (Left x) | Just ErrorCall{} <- fromException x -> True + _ -> False + +tryBracketTest :: Test +tryBracketTest = TestLabel "tryBracket" . TestCase $ do + r <- tryAll $ tryBracket + (throwIO (ErrorCall "a")) + (\_ _ -> throwIO (ErrorCall "b")) + (\_ -> throwIO (ErrorCall "c")) + assertBool "tryBracket1" $ case r of + Left e | Just (ErrorCall "a") <- fromException e -> True + _other -> False + r <- tryAll $ tryBracket + (return 'a') + (\'a' _ -> throwIO (ErrorCall "b")) -- release throws; this is what we get + (\'a' -> throwIO (ErrorCall "c")) + assertBool "tryBracket2" $ case r of + Left e | Just (ErrorCall "b") <- fromException e -> True + _other -> False + r <- tryAll $ tryBracket + (return 'a') + (\'a' Left{} -> return ()) + (\'a' -> throwIO (ErrorCall "c")) + assertBool "tryBracket3" $ case r of + Left e | Just (ErrorCall "c") <- fromException e -> True + _other -> False + r <- tryAll $ tryBracket + (return 'a') + (\'a' Right{} -> return ()) + (\'a' -> return 'c') + assertBool "tryBracket4" $ case r of + Right 'c' -> True + _other -> False + +tryFinallyTest :: Test +tryFinallyTest = TestLabel "tryFinally" . TestCase $ do + r <- tryAll $ tryFinally + (throwIO (ErrorCall "a")) + (\Left{} -> throwIO (ErrorCall "b")) + assertBool "tryFinally1" $ case r of + Left e | Just (ErrorCall "b") <- fromException e -> True + _other -> False + r <- tryAll $ tryFinally + (return 'a') + (\Right{} -> throwIO (ErrorCall "b")) + -- release throws; this is what we get + assertBool "tryFinally2" $ case r of + Left e | Just (ErrorCall "b") <- fromException e -> True + _other -> False + +main :: IO () +main = testRunner $ TestList + [ catchAllTest + , tryAllTest + , tryBracketTest + , tryFinallyTest + ] diff --git a/tests/FilePathTest.hs b/tests/FilePathTest.hs new file mode 100644 --- /dev/null +++ b/tests/FilePathTest.hs @@ -0,0 +1,103 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module FilePathTest (main) where + +import Data.Text (Text) + +import Test.HUnit +import TestRunner + +import Util.FilePath + +dirEnv :: DirEnv +dirEnv = DirEnv{ homeDir = "/home/sweethome/", currentDir = "/herp" } + +homeDirTest :: Test +homeDirTest = TestLabel "~/ handled" . TestCase $ do + assertEqual "raw ~" + "/home/sweethome/" + (absolutiseWith dirEnv "~") + assertEqual "~/derp" + "/home/sweethome/derp" + (absolutiseWith dirEnv "~/derp") + assertEqual "relative path with ~" + "/home/sweethome/../derp" + (absolutiseWith dirEnv "~/../derp") + +relPathTest :: Test +relPathTest = TestLabel "relative path handled" . TestCase $ do + assertEqual "Relative path" + "/herp/derp" + (absolutiseWith dirEnv "derp") + assertEqual "Relative path" + "/herp/derp" + (absolutiseWith dirEnv ".//derp") + assertEqual "Relative path" + "/herp/../derp" + (absolutiseWith dirEnv "../derp") + +testPathToMName :: Test +testPathToMName = TestList + [ mkPathToModuleTestCase + "Basic" + "Foo/Bar/Baz/Quux.hs" + "Foo.Bar.Baz.Quux" + , mkPathToModuleTestCase + "Rooted" + "sigma/repo/Foo/Bar/Baz.hs" + "Foo.Bar.Baz" + , mkPathToModuleTestCase + "Deeply rooted test" + "sigma/repo/Foo.hs" + "Foo" + , mkPathToModuleTestCase + "Absolute Filename" + "/data/users/gnickstanley/si_sigma/Contexts/TestContext.hs" + "Contexts.TestContext" + , mkPathToModuleTestCase + "Subproject Filename" + "duckling/Duckling/Ranking/Types.hs" + "Duckling.Ranking.Types" + , mkPathToModuleTestCase + "Rooted Subproject" + "si_sigma/duckling/Duckling/Ranking/Types.hs" + "Duckling.Ranking.Types" + , mkPathToModuleTestCase + "Absolute Subproject" + "/data/users/gnickstanley/si_sigma/duckling/Duckling/Ranking/Types.hs" + "Duckling.Ranking.Types" + , mkPathToModuleTestCase + "Other Capitalized Directories" + "/data/users/ILOVECAPITALIZEDUSERNAMES/si_sigma/Contexts/TestContext.hs" + "Contexts.TestContext" + ] + +mkPathToModuleTestCase :: String -> FilePath -> Text -> Test +mkPathToModuleTestCase name path expected = + TestLabel name . TestCase $ expected @=? pathToMName path + +testMNameToPath :: Test +testMNameToPath = TestList + [ mkMNameToPathTestCase + "Basic" + "Foo.Bar.Baz.Quux" + "Foo/Bar/Baz/Quux.hs" + ] + +mkMNameToPathTestCase :: String -> Text -> FilePath -> Test +mkMNameToPathTestCase name mname expected = + TestLabel name . TestCase $ expected @=? mnameToPath mname + +main :: IO () +main = testRunner $ TestList + [ homeDirTest + , relPathTest + , testPathToMName + , testMNameToPath + ] diff --git a/tests/GraphTest.hs b/tests/GraphTest.hs new file mode 100644 --- /dev/null +++ b/tests/GraphTest.hs @@ -0,0 +1,49 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module GraphTest (main) where + +import Control.Monad +import qualified Data.IntMap as IntMap +import Data.Maybe + +import Test.QuickCheck +import Test.HUnit +import TestRunner +import Util.Graph + +main :: IO () +main = testRunner $ TestList + [ TestLabel "postorder" $ TestCase $ do + result <- quickCheckResult prop_postorder + case result of + Success{} -> return () + _ -> assertFailure "failed" + ] + +prop_postorder :: Property +prop_postorder = do + forAll graphs $ \(nodes, outMap) -> + check nodes outMap && check (reverse nodes) outMap + -- regardless of the input order of the nodes, dependencies should + -- appear before dependents in the output. + where + check nodes outMap = + and [ posOf o < posOf n | n <- nodes, o <- out n ] + where + out n = fromJust (IntMap.lookup n outMap) + order = postorder nodes id out + pos = IntMap.fromList (zip order [(0::Int)..]) + posOf n = fromJust (IntMap.lookup n pos) + + graphs = do + NonNegative numNodes <- arbitrary + edges <- forM [1..numNodes] $ \n -> do + outs <- sublistOf [1..n-1] -- only earlier nodes, so we get no cycles + return (n,outs) + return ([1..numNodes], IntMap.fromList edges) diff --git a/tests/HsStructHelper.cpp b/tests/HsStructHelper.cpp new file mode 100644 --- /dev/null +++ b/tests/HsStructHelper.cpp @@ -0,0 +1,160 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include "tests/HsStructHelper.h" + +#include +#include +#include +#include "cpp/HsStruct.h" + +using namespace std; +using namespace std::string_literals; + +namespace facebook::common::hs { + +HS_DEFINE_DESTRUCTIBLE(HsMaybeNonmovable, HsMaybe); +HS_STD_TUPLE_CPP(CppTupleIntJSONOnlyMovable); +HS_STD_TUPLE_CPP(TupleStringString); + +extern "C" { + +HsMaybe* getHsMaybeNonmovable() noexcept { + // test the std::unique_ptr constrcutor + static HsMaybe ret(std::make_unique(9, "Crino"s)); + return &ret; +} + +HsMaybe* createHsMaybeNonmovable( + int64_t resource, + const char* str, + int64_t len) noexcept { + // test the std::in_place_t constrcutor + HsMaybe ret(std::in_place, resource, std::string(str, len)); + // HsMaybe itself is still safely movable + return new HsMaybe(std::move(ret)); +} + +void fillCppTuple(hs_std_tuple::CppTupleIntJSONOnlyMovable* t) noexcept { + *t = hs_std_tuple::CppTupleIntJSONOnlyMovable(std::make_tuple( + 42, + true, + facebook::common::hs::OnlyMovable(8), + HsEither(HsLeft, HsString("wut"s)))); +} + +} // extern "C" + +} // namespace facebook::common::hs + +HS_STD_VARIANT_CPP(MyCppVariant); +HS_OPTION_CPP(MyCppVariant, hs_std_variant::MyCppVariant); +HS_OPTION_CPP(TupleStringString, FB_SINGLE_ARG(HsStdTuple)); + +extern "C" { + +bool checkHsText(HsString val, const char* str, size_t len) { + return val.getStr() == std::string(str, len); +} + +bool checkHsEither(HsEither* val, int left_or_right) { + switch (left_or_right) { + case 1: + return val->getLeft().getStr() == "string from haskell"; + case 2: + return val->getRight() == 42; + default: + throw std::runtime_error(std::string( + "checkHsEither: left_or_right should be either 1 or 2. Given: %d", + left_or_right)); + } +} + +HsMaybe* getNothing() noexcept { + static HsMaybe ret; + return &ret; +} + +HsMaybe* getJust() noexcept { + static HsMaybe ret("just"s); + return &ret; +} + +HsEither* getLeft() noexcept { + static HsEither ret(HsLeft, "error"s); + return &ret; +} + +HsEither* getRight() noexcept { + static HsEither ret(HsRight, 42); + return &ret; +} + +HsArray* getArray() noexcept { + static HsArray ret{"foo"s, "bar"s}; + return &ret; +} + +HsArray* getArrayInt64() noexcept { + static HsArray ret{1, 2, 3}; + return &ret; +} + +// HsArrayBool uses bytes because std::vector does +// not use a contiguous array representation +HsArray* getArrayCBool() noexcept { + static HsArray ret{true, false, true, true, true, false}; + return &ret; +} + +HsSet* getSet() noexcept { + static HsSet ret{"foo"s, "bar"s}; + return &ret; +} + +HsSet* getSetInt64() noexcept { + static HsSet ret{1, 2, 3}; + return &ret; +} + +HsIntMap* getIntMap() noexcept { + static HsIntMap ret{{2, 4}, {3, 9}, {5, 25}, {7, 49}}; + return &ret; +} + +HsMap* getIntHashMap() noexcept { + static HsMap ret{{2, 4}, {3, 9}, {5, 25}, {7, 49}}; + return &ret; +} + +HsPair* getPair() noexcept { + static auto ret = HsPair("foo"s, 3); + return &ret; +} + +using HsNested = HsObject>>>; + +HsNested* createNested() noexcept { + map>>> ret; + ret["zero"]; + ret["one"][1]; + ret["two"][2].emplace_back(folly::none); + auto& more = ret["more"]; + more[3].emplace_back(folly::none); + more[4].emplace_back("two"s); + more[5].emplace_back(folly::none); + more[5].emplace_back(""s); + more[6].emplace_back("two"s); + more[6].emplace_back("three"s); + return new HsNested(std::move(ret)); +} + +void destroyNested(HsNested* p) noexcept { + delete p; +} +} diff --git a/tests/HsStructHelper.h b/tests/HsStructHelper.h new file mode 100644 --- /dev/null +++ b/tests/HsStructHelper.h @@ -0,0 +1,60 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#pragma once + +#include +#include "cpp/HsStruct.h" + +namespace facebook::common::hs { + +HS_STRUCT OnlyMovable { + int64_t r_; + + public: + OnlyMovable() = delete; + explicit OnlyMovable(int64_t r) : r_(r) {} + + OnlyMovable(const OnlyMovable&) = delete; + OnlyMovable& operator=(const OnlyMovable&) = delete; + + OnlyMovable(OnlyMovable&&) = default; + OnlyMovable& operator=(OnlyMovable&&) = delete; +}; + +HS_STRUCT Nonmovable { + int64_t resource; + HsString description; + + public: + Nonmovable(int64_t resource, std::string && description) + : resource(resource), description(std::move(description)) {} + + ~Nonmovable() { + // free_resource(resource); + } + + Nonmovable(const Nonmovable&) = delete; + Nonmovable(Nonmovable&&) = delete; + Nonmovable& operator=(const Nonmovable&) = delete; + Nonmovable& operator=(Nonmovable&&) = delete; +}; + +} // namespace facebook::common::hs + +HS_STD_VARIANT_H(MyCppVariant, int32_t, HsString, HsOption); +HS_OPTION_H(MyCppVariant, hs_std_variant::MyCppVariant); +HS_STD_TUPLE_H( + CppTupleIntJSONOnlyMovable, + FB_SINGLE_ARG( + int32_t, + HsJSON, + facebook::common::hs::OnlyMovable, + HsEither)); +HS_STD_TUPLE_H(TupleStringString, FB_SINGLE_ARG(HsString, HsString)); +HS_OPTION_H(TupleStringString, FB_SINGLE_ARG(HsStdTuple)); diff --git a/tests/HsStructTest.hs b/tests/HsStructTest.hs new file mode 100644 --- /dev/null +++ b/tests/HsStructTest.hs @@ -0,0 +1,495 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module HsStructTest (main) where + +import Test.HUnit +import TestRunner + +import Control.Exception +import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString, useAsCStringLen) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map +import Data.Scientific (Scientific, fromFloatDigits) +import Data.Text (Text) +import qualified Data.Text.Encoding as Text (encodeUtf8) +import Data.Tuple.Extra ((***)) +import qualified Data.Vector as Vector +import qualified Data.Vector.Storable as VectorStorable +import Foreign +import Foreign.C.Types (CBool (..), CChar) + +import Foreign.CPP.HsStruct +import Foreign.CPP.Marshallable +import Util.Aeson + +import qualified HsStructTestTypes as TT + +foreign import ccall unsafe "fillCppTuple" + c_fillCppTuple :: Ptr (HsStdTuple (Int32, HsJSON, TT.OnlyMovable, HsEither HsText Int)) -> IO () + +stdTupleTest :: Test +stdTupleTest = TestLabel "stdTupleTest" $ TestCase $ do + withCxxObject (HsStdTuple t_val) (testTuple "tuple roundtrip") + + withDefaultCxxObject $ \ptr -> do + c_fillCppTuple ptr + testTuple "peeked" ptr + + where + i_val = 42 :: Int32 + j_val = Aeson.Bool True + n_val = TT.OnlyMovable 8 + e_val = Left (HsText "wut") :: Either HsText Int + t_val = (i_val, HsJSON j_val, n_val, HsEither e_val) + + testTuple pref ptr = do + (HsStdTuple (peeked_i, HsJSON peeked_j, peeked_n, HsEither peeked_e)) <- + peek ptr + assertEqual (pref ++ " int") i_val peeked_i + assertEqual (pref ++ " json") j_val peeked_j + assertEqual (pref ++ " OnlyMovable") n_val peeked_n + case (e_val, peeked_e) of + (Left (HsText a), Left (HsText b)) -> + assertEqual (pref ++ " Either") a b + _ -> assertFailure (pref ++ " Either peeking failed") + +stdVariantTest :: Test +stdVariantTest = TestLabel "stdVariantTest" $ + TestCase $ do + let i_val = 1337 + withCxxObject (TT.I i_val) $ \i_p -> do + peeked_i <- peek i_p :: IO TT.MyVariant + case peeked_i of + TT.I peeked_i_val -> assertEqual "int roundtrip" i_val peeked_i_val + _ -> assertFailure "Didn't get int back from roundtrip" + + let s_val = "WUT" + withCxxObject (TT.S (HsByteString s_val)) $ \s_p -> do + peeked_s <- peek s_p :: IO TT.MyVariant + case peeked_s of + TT.S (HsByteString peeked_s_val) -> + assertEqual "string roundtrip" s_val peeked_s_val + _ -> assertFailure "Didn't get string back from roundtrip" + + let opt_val = TT.J (HsOption (Just (HsJSON (Aeson.Bool True)))) + withCxxObject (HsOption (Just opt_val)) $ \j_p -> do + HsOption peeked_j <- peek j_p :: IO (HsOption TT.MyVariant) + case peeked_j of + Just (TT.J (HsOption (Just (HsJSON (Aeson.Bool v))))) -> + assertBool "Json bool roundtrip" v + _ -> assertFailure "Didn't get option of Json back" + +arrayCxxTest :: Test +arrayCxxTest = TestLabel "arrayCxxTest" $ + TestCase $ do + withDefaultCxxObject $ \p -> do + HsList v <- peek p :: IO (HsList HsText) + assertEqual "default is empty" [] (map hsText v) + + let pokey = ["1", "2", "3"] + withCxxObject (HsList (map HsText pokey)) $ \p -> do + HsList v <- peek p + assertEqual "list of strings" pokey (map hsText v) + + withDefaultCxxObject $ \p -> do + HsArray v <- peek p :: IO (HsArray HsText) + assertEqual "default is empty" [] (map hsText (Vector.toList v)) + + withCxxObject (HsArray (Vector.fromList (map HsText pokey))) $ \p -> do + HsArray v <- peek p + assertEqual "array of strings" pokey (Vector.toList (Vector.map hsText v)) + + let booley = fmap toCBool [False, True, True, False, False, True] + withCxxObject (HsArray (Vector.fromList booley)) $ \p -> do + HsArray v <- peek p + assertEqual "array of bool" booley (Vector.toList v) + +setCxxTest :: Test +setCxxTest = TestLabel "setCxxTest" $ + TestCase $ do + withDefaultCxxObject $ \p -> do + HsHashSet s <- peek p :: IO (HsHashSet HsText) + assertEqual + "default is empty" + HashSet.empty + (HashSet.map hsText s) + + let pokey = ["1", "2", "3", "2"] + let pokeySet = HashSet.fromList pokey + withCxxObject (HsHashSet $ HashSet.map HsText pokeySet) $ \p -> do + HsHashSet s <- peek p + assertEqual + "set of strings" + pokeySet + (HashSet.map hsText s) + + let pokeyInt :: [Int] = [1, 2, 3, 2] + let pokeyIntSet = HashSet.fromList pokeyInt + withCxxObject (HsHashSet pokeyIntSet) $ \p -> do + HsHashSet s <- peek p + assertEqual "set of ints" pokeyIntSet s + + let pokeyDouble :: [Double] = [1.0, 2.0, 3.0, 2.0] + let pokeyDoubleSet = HashSet.fromList pokeyDouble + withCxxObject (HsHashSet pokeyDoubleSet) $ \p -> do + HsHashSet s <- peek p + assertEqual + "set of doubles" + pokeyDoubleSet + s + +mapCxxTest :: Test +mapCxxTest = TestLabel "mapCxxTest" $ + TestCase $ do + let map_kv = \kf vf -> HashMap.fromList . map (kf *** vf) . HashMap.toList + withDefaultCxxObject $ \p -> do + HsHashMap s <- peek p :: IO (HsHashMap HsText HsText) + assertEqual + "default is empty" + HashMap.empty + (map_kv hsText hsText s) + + let pokey :: [(Text, Text)] = + [("1", "a"), ("2", "b"), ("3", "c")] + let pokeyMap = HashMap.fromList pokey + withCxxObject (HsHashMap $ map_kv HsText HsText pokeyMap) $ \p -> do + HsHashMap s <- peek p + assertEqual + "map from strings to strings" + pokeyMap + (map_kv hsText hsText s) + + let pokeyDuplicate :: [(Text, Text)] = + [("1", "a"), ("2", "b"), ("3", "c"), ("2", "d")] + let pokeyDuplicateMap = HashMap.fromList pokeyDuplicate + withCxxObject (HsHashMap $ map_kv HsText HsText pokeyDuplicateMap) $ \p -> + do + HsHashMap s <- peek p + assertEqual + "map from strings to strings with duplicates" + pokeyDuplicateMap + (map_kv hsText hsText s) + + let pokeyInt :: [(Int32, Text)] = [(1, "a"), (2, "b"), (3, "c"), (2, "d")] + let pokeyIntMap = HashMap.fromList pokeyInt + withCxxObject (HsHashMap $ map_kv id HsText pokeyIntMap) $ \p -> do + HsHashMap s <- peek p + assertEqual + "map from ints to strings with duplicates" + pokeyIntMap + (map_kv id hsText s) + + let pokeyDouble :: [(Double, Int32)] = + [(1.0, 19), (2.0, 29), (3.0, 39), (2.0, 9)] + let pokeyDoubleMap = HashMap.fromList pokeyDouble + withCxxObject (HsHashMap pokeyDoubleMap) $ \p -> do + HsHashMap s <- peek p + assertEqual + "map from doubles to ints with duplicates" + pokeyDoubleMap + s + +toCBool :: Bool -> CBool +toCBool = fromBool + +stringPieceCxxTest :: Test +stringPieceCxxTest = TestLabel "stringPieceCxxTest" $ + TestCase $ do + withDefaultCxxObject $ \p -> do + HsRange ptr len <- peek p :: IO HsStringPiece + assertEqual "ptr" nullPtr ptr + assertEqual "len" 0 len + + let pokeString = "pokey" :: ByteString + useAsCStringLen pokeString $ \(pPtr, pLen) -> + withCxxObject (HsRange pPtr pLen) $ \p -> do + HsRange rPtr rLen <- peek p + assertEqual "rPtr" pPtr rPtr + assertEqual "rLen" pLen rLen + +optionTest :: Test +optionTest = TestLabel "optionTest" $ + TestCase $ do + withDefaultCxxObject $ \p -> do + HsOption v <- peek p + case v of + Just (HsText _) -> assertFailure "Should not have received anything" + Nothing -> return () + + let pokeString = "pokey" + withCxxObject (HsOption (Just $ HsText pokeString)) $ \p -> do + HsOption o <- peek p + case o of + Just (HsText v) -> assertEqual "alloc text was set" pokeString v + Nothing -> assertFailure "Should have received something" + + let pokeVal = 5 :: Int64 + withCxxObject (HsOption (Just pokeVal)) $ \p -> do + HsOption o <- peek p + case o of + Just v -> assertEqual "alloc int was set" pokeVal v + Nothing -> assertFailure "Should have received something" + +allocUtilsTest :: Test +allocUtilsTest = TestLabel "allocUtilsTest" $ + TestCase $ do + let pokeString = "pokey" + withDefaultCxxObject $ \p -> do + assign p (HsText pokeString) + HsText v <- peek p + assertEqual "poked string was set" pokeString v + + withCxxObject (HsText pokeString) $ \p -> do + HsText v <- peek p + assertEqual "alloc string was set" pokeString v + +foreign import ccall unsafe "checkHsText" + c_checkHsText :: Ptr HsText -> Ptr CChar -> Word -> IO CBool + +pokeHsTextTest :: Test +pokeHsTextTest = TestLabel "pokeHsTextTest" $ + TestCase $ do + let ctorString = "constructed string" + pokeString = "poked string" + withCxxObject (HsText ctorString) $ \p -> do + check_1 <- unsafeUseAsCStringLen (Text.encodeUtf8 ctorString) $ + \(str, len) -> c_checkHsText p str (fromIntegral len) + assertBool "constructed string not matches" (toBool check_1) + + assign p (HsText pokeString) + check_2 <- unsafeUseAsCStringLen (Text.encodeUtf8 pokeString) $ + \(str, len) -> c_checkHsText p str (fromIntegral len) + assertBool "poked string not matches" (toBool check_2) + +maybeTest :: Test +maybeTest = TestLabel "Maybe" $ + TestCase $ do + (nothing :: Maybe String) <- coerce $ peek =<< getNothing + assertEqual "Nothing" Nothing nothing + (just :: Maybe String) <- coerce $ peek =<< getJust + assertEqual "Just Text" (Just "just") just + +foreign import ccall unsafe "getNothing" + getNothing :: IO (Ptr (HsMaybe HsString)) + +foreign import ccall unsafe "getJust" + getJust :: IO (Ptr (HsMaybe HsString)) + +maybeNonmovableTest :: Test +maybeNonmovableTest = TestLabel "HsMaybeNonmovable" $ + TestCase $ do + HsMaybe got <- peek =<< getHsMaybeNonmovable + assertEqual "get" (Just $ TT.Nonmovable 9 "Crino") got + p <- unsafeUseAsCStringLen descritpion $ \(str, len) -> + mask_ $ toSharedPtr =<< createHsMaybeNonmovable 101 str len + HsMaybe created <- withForeignPtr p peek + assertEqual "created" (Just $ TT.Nonmovable 101 descritpion) created + where + descritpion = "descritpion" + +foreign import ccall unsafe "getHsMaybeNonmovable" + getHsMaybeNonmovable :: IO (Ptr (HsMaybe TT.Nonmovable)) + +foreign import ccall unsafe "createHsMaybeNonmovable" + createHsMaybeNonmovable :: + Int -> Ptr CChar -> Int -> IO (Ptr (HsMaybe TT.Nonmovable)) + +peekHsEitherTest :: Test +peekHsEitherTest = TestLabel "peekHsEitherTest" $ + TestCase $ do + (left :: Either String Int) <- coerce $ peek =<< getLeft + assertEqual "Left" (Left "error") left + (right :: Either String Int) <- coerce $ peek =<< getRight + assertEqual "Right" (Right 42) right + +foreign import ccall unsafe "getLeft" + getLeft :: IO (Ptr (HsEither HsString Int)) + +foreign import ccall unsafe "getRight" + getRight :: IO (Ptr (HsEither HsString Int)) + +pokeHsEitherTest :: Test +pokeHsEitherTest = TestLabel "pokeHsEitherTest" $ + TestCase $ do + let initialValue :: HsEither HsText Int + initialValue = HsEither (Left (HsText "string from haskell")) + updatedValue :: HsEither HsText Int + updatedValue = HsEither (Right 42) + withCxxObject initialValue $ \p -> do + check_1 <- c_checkHsEither p 1 + assertBool "Left value not matches" (toBool check_1) + assign p updatedValue + check_2 <- c_checkHsEither p 2 + assertBool "Right value not matches" (toBool check_2) + +foreign import ccall unsafe "checkHsEither" + c_checkHsEither :: Ptr (HsEither HsText Int) -> Int -> IO CBool + +arrayTest :: Test +arrayTest = TestLabel "Array" $ + TestCase $ do + s <- fmap (fmap hsString . hsArray) $ peek =<< getArray + assertEqual "Vector String" (Vector.fromList ["foo", "bar"]) s + bs <- fmap (map hsByteString . hsList) $ peek =<< getArray + assertEqual "[ByteString]" ["foo", "bar"] bs + t <- fmap (map hsText . hsList) $ peek =<< getArray + assertEqual "[Text]" ["foo", "bar"] t + v <- fmap hsArrayStorable $ peek =<< getArrayInt64 + assertEqual "VectorStorable Int64" (VectorStorable.fromList [1 :: Int64, 2, 3]) v + bv <- fmap hsArray $ peek =<< getArrayCBool + assertEqual "CBool Size" 1 (sizeOf (CBool 0)) + assertEqual "CBool Align" 1 (alignment (CBool 1)) + let expected = fmap toCBool [True, False, True, True, True, False] + assertEqual "Vector Bool" (Vector.fromList expected) bv + +foreign import ccall unsafe "getArray" + getArray :: IO (Ptr a) + +foreign import ccall unsafe "getArrayInt64" + getArrayInt64 :: IO (Ptr a) + +foreign import ccall unsafe "getArrayCBool" + getArrayCBool :: IO (Ptr a) + +setTest :: Test +setTest = TestLabel "Set" $ + TestCase $ do + s :: HsHashSet HsText <- peek =<< getSet + assertEqual + "HashSet String" + (HashSet.fromList ["foo", "bar"]) + (HashSet.map hsText $ hsHashSet s) + + si :: HsHashSet Int64 <- peek =<< getSetInt64 + assertEqual + "HashSet Int64" + (HashSet.fromList [1, 2, 3]) + (hsHashSet si) + +foreign import ccall unsafe "getSet" + getSet :: IO (Ptr a) + +foreign import ccall unsafe "getSetInt64" + getSetInt64 :: IO (Ptr a) + +mapTest :: Test +mapTest = TestLabel "Map" $ + TestCase $ do + HsMap m <- peek =<< getIntMap + assertEqual "Map Int Int" (Map.fromList assocs) m + HsIntMap im <- peek =<< getIntMap + assertEqual "IntMap Int" (IntMap.fromList assocs) im + HsHashMap hm <- peek =<< getIntHashMap + assertEqual + "HashMap Int Int" + (HashMap.fromList assocs) + hm + where + assocs = [(2, 4), (3, 9), (5, 25), (7, 49)] :: [(Int, Int)] + +foreign import ccall unsafe "getIntMap" + getIntMap :: IO (Ptr a) + +foreign import ccall unsafe "getIntHashMap" + getIntHashMap :: IO (Ptr a) + +pairTest :: Test +pairTest = TestLabel "Pair" $ + TestCase $ do + HsPair (HsText f, s) :: HsPair HsText Int <- peek =<< getPair + assertEqual "Pair" ("foo", 3) (f, s) + +foreign import ccall unsafe "getPair" + getPair :: IO (Ptr a) + +type Nested = KeyMap (IntMap [Maybe Text]) +type HsNested = HsObject (HsIntMap (HsList (HsMaybe HsText))) + +nestedTest :: Test +nestedTest = TestLabel "nested" $ + TestCase $ do + actual :: Nested <- coerce $ bracket createNested destroyNested peek + assertEqual "Nested" expected actual + where + expected = + objectFromList + [ (keyFromText "zero", IntMap.empty) + , (keyFromText "one", IntMap.singleton 1 []) + , (keyFromText "two", IntMap.singleton 2 [Nothing]) + , + ( keyFromText "more" + , IntMap.fromList + [ (3, [Nothing]) + , (4, [Just "two"]) + , (5, [Nothing, Just ""]) + , (6, [Just "two", Just "three"]) + ] + ) + ] + +foreign import ccall unsafe "createNested" + createNested :: IO (Ptr HsNested) + +foreign import ccall unsafe "destroyNested" + destroyNested :: Ptr HsNested -> IO () + +jsonRoundTrip :: Test +jsonRoundTrip = TestLabel "json" $ + TestCase $ do + roundTrip Aeson.Null + roundTrip (Aeson.Bool True) + roundTrip (Aeson.Bool False) + roundTrip (Aeson.Number (read "42" :: Scientific)) + roundTrip (Aeson.Number (read "-42" :: Scientific)) + roundTrip (Aeson.Number (fromFloatDigits (3.14159 :: Double))) + roundTrip (Aeson.String "Data.Aeson") + roundTrip + ( Aeson.Array $ + Vector.fromList + [Aeson.Null, Aeson.Bool True, Aeson.String "VectorVector"] + ) + roundTrip + ( Aeson.Object $ + objectFromList + [(keyFromText "foo", Aeson.Bool True), (keyFromText "bar", Aeson.Bool False)] + ) + where + roundTrip j = withCxxObject (HsJSON j) $ \p -> do + HsJSON v <- peek p + assertEqual "json round trip" j v + +main :: IO () +main = + testRunner $ + TestList + [ pokeHsTextTest + , maybeTest + , maybeNonmovableTest + , peekHsEitherTest + , pokeHsEitherTest + , arrayTest + , mapCxxTest + , mapTest + , pairTest + , nestedTest + , allocUtilsTest + , optionTest + , arrayCxxTest + , setCxxTest + , setTest + , stringPieceCxxTest + , jsonRoundTrip + , stdVariantTest + , stdTupleTest + ] diff --git a/tests/HsStructTestTypes.hsc b/tests/HsStructTestTypes.hsc new file mode 100644 --- /dev/null +++ b/tests/HsStructTestTypes.hsc @@ -0,0 +1,84 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module HsStructTestTypes + ( Nonmovable(..) + , OnlyMovable(..) + , MyVariant(..) + ) where + +import Data.ByteString (ByteString) +import Data.Int + +import Foreign +import Foreign.C.Types +import Foreign.CPP.HsStruct +import Foreign.CPP.HsStruct.HsOption +import Foreign.CPP.HsStruct.HsStdTuple +import Foreign.CPP.HsStruct.HsStdVariant +import Foreign.CPP.Marshallable.TH + +#include +#include +#include +#include + +#{verbatim using facebook::common::hs::OnlyMovable;} +#{verbatim using facebook::common::hs::Nonmovable;} + +data Nonmovable = Nonmovable Int ByteString + deriving (Eq, Show) + +instance Addressable Nonmovable + +instance Storable Nonmovable where + sizeOf _ = #{size HsMaybe} + alignment _ = #{alignment HsMaybe} + poke = error "Nonmovable: poke not implemented" + peek p = do + resource <- #{peek Nonmovable, resource} p + description <- #{peek Nonmovable, description} p + return $ Nonmovable resource $ hsByteString description + +$(deriveDestructibleUnsafe "HsMaybeNonmovable" [t| HsMaybe Nonmovable |]) + +data OnlyMovable = OnlyMovable Int + deriving (Eq, Show) + +instance Addressable OnlyMovable + +instance Storable OnlyMovable where + sizeOf _ = #{size OnlyMovable} + alignment _ = #{alignment OnlyMovable} + poke p (OnlyMovable r) = #{poke OnlyMovable, r_} p r + peek p = do + resource <- #{peek OnlyMovable, r_} p + return $ OnlyMovable resource + + +data MyVariant + = I Int32 + | S HsByteString + | J (HsOption HsJSON) + +-- Marshallable first +$(deriveMarshallableUnsafe "HsOptionMyCppVariant" [t| HsOption MyVariant |]) +$(deriveMarshallableUnsafe "MyCppVariant" [t| MyVariant |]) +$(deriveMarshallableUnsafe "CppTupleIntJSONOnlyMovable" [t| HsStdTuple (Int32, HsJSON, OnlyMovable, HsEither HsText Int) |]) +$(deriveMarshallableUnsafe "TupleStringString" [t| HsStdTuple (HsText, HsText) |]) +$(deriveMarshallableUnsafe "HsOptionTupleStringString" [t| HsOption (HsStdTuple (HsText, HsText)) |]) + +-- Constructions next +$(#{derive_hs_std_variant_unsafe MyCppVariant} "MyVariant" [t| MyVariant |]) +$(#{derive_hs_option_unsafe MyCppVariant} [t| MyVariant |]) +$(#{derive_hs_std_tuple_unsafe CppTupleIntJSONOnlyMovable} [t| (Int32, HsJSON, OnlyMovable, HsEither HsText Int) |]) +$(#{derive_hs_std_tuple_unsafe TupleStringString} [t| (HsText, HsText) |]) +$(#{derive_hs_option_unsafe TupleStringString} [t| HsStdTuple (HsText, HsText) |]) diff --git a/tests/IOBufTest.cpp b/tests/IOBufTest.cpp new file mode 100644 --- /dev/null +++ b/tests/IOBufTest.cpp @@ -0,0 +1,43 @@ +/* + * Copyright (c) Meta Platforms, Inc. and affiliates. + * All rights reserved. + * + * This source code is licensed under the BSD-style license found in the + * LICENSE file in the root directory of this source tree. + */ + +#include +#include + +extern "C" { + +uint8_t* echo(HS_IOBuf* hs_iobuf) noexcept { + auto ioBuf = common::hs::newIOBufWrapping(hs_iobuf); + + auto str = ioBuf->moveToFbString(); + auto len = str.length(); + + // This will get free'd by the haskell garbage collector + auto buf = static_cast(malloc(len + 1)); + memcpy((void*)buf, (void*)str.c_str(), len); + buf[len] = 0; // Null terminator + + return buf; +} + +IOBuf* create_buffer() noexcept { + const char* const strs[] = { + "All happy families are alike; ", + "every unhappy family is unhappy in its own way."}; + const int lens[] = {30, 47}; + std::unique_ptr bufs[2]; + for (size_t i = 0; i < 2; i++) { + bufs[i] = IOBuf::createCombined(50); + strncpy((char*)bufs[i]->writableData(), strs[i], lens[i]); + bufs[i]->append(lens[i]); + if (i) + bufs[0]->appendChain(std::move(bufs[i])); + } + return bufs[0].release(); +} +} diff --git a/tests/IOBufTest.hs b/tests/IOBufTest.hs new file mode 100644 --- /dev/null +++ b/tests/IOBufTest.hs @@ -0,0 +1,44 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module IOBufTest where + +import Data.ByteString.Lazy as Lazy +import Data.ByteString.Unsafe +import Foreign.C +import Foreign.Ptr +import Util.IOBuf +import TestRunner +import Test.HUnit + +lazyBS :: Lazy.ByteString +lazyBS = fromChunks ["hello", " ", "world"] + +roundTripTest :: Test +roundTripTest = TestLabel "round trip" $ TestCase $ do + bs <- unsafePackMallocCString =<< unsafeWithIOBuf lazyBS c_echo + assertEqual "echo'd" "hello world" bs + +-- `show` adds quotes +testString :: String +testString = "\"All happy families are alike; " ++ + "every unhappy family is unhappy in its own way.\"" + +fromCTest :: Test +fromCTest = TestLabel "from C" $ TestCase $ do + x <- toLazy c_create + assertEqual "marshalled" testString $ show x + +main :: IO () +main = testRunner $ TestList [ roundTripTest, fromCTest ] + +-------------------------------------------------------------------------------- + +foreign import ccall "echo" + c_echo :: Ptr IOBuf -> IO CString +foreign import ccall unsafe "create_buffer" c_create :: Ptr IOBuf diff --git a/tests/IOTest.hs b/tests/IOTest.hs new file mode 100644 --- /dev/null +++ b/tests/IOTest.hs @@ -0,0 +1,32 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module IOTest + ( main + ) where + +import System.Directory +import System.FilePath +import System.IO.Temp +import TestRunner +import Test.HUnit +import Util.IO + +main :: IO () +main = testRunner $ TestList + [ writeFileAtomicUTF8Test ] + +writeFileAtomicUTF8Test :: Test +writeFileAtomicUTF8Test = TestLabel + "creates if file and parent dir does not exist" $ TestCase $ + withSystemTempDirectory "writeFileAtomicUTF8Test" $ \tmpRoot -> do + let + testFile = tmpRoot "nested" "writeFileAtomicUTF8Test.tmp" + do + writeFileAtomicUTF8 testFile "writeFileAtomicUTF8Test" + doesFileExist testFile >>= assertBool "File should exist" diff --git a/tests/JSONPrettyTest.hs b/tests/JSONPrettyTest.hs new file mode 100644 --- /dev/null +++ b/tests/JSONPrettyTest.hs @@ -0,0 +1,41 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module JSONPrettyTest (main) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as B +import Compat.Prettyprinter as Pretty hiding ((<>)) +import Text.JSON + +import Test.HUnit +import TestRunner + +import Util.JSON.Pretty () +import Util.String.Quasi + +jsonString :: String +jsonString = [s|{"byt":33,"nat":42,"array_of_byte":"eHl6AAB4ZmY","array_of_nat":[99,98],"record_":{"a":34,"b":35},"sum_":{"d":36},"named_record_":{"alpha":1,"beta":{"wed":true}},"named_sum_":{"tue":37},"named_enum_":2,"pred":{"id":3},"maybe_":{},"bool_":true,"string_":"Hello\u0000world!\u0000","null_":null}|] + +jsonPrettyTest :: Test +jsonPrettyTest = TestLabel "jsonPrettyTest" $ TestCase $ do + json <- case Text.JSON.decode jsonString of + Error _ -> assertFailure "parse" + Ok (v :: JSValue) -> return v + let + prettyJson = show $ pretty json + Just v0 = Aeson.decode (B.pack jsonString) :: Maybe Aeson.Value + Just v1 = Aeson.decode (B.pack prettyJson) + assertEqual "pretty" v0 v1 + +main :: IO () +main = testRunner $ TestList + [ jsonPrettyTest + ] diff --git a/tests/LensTest.hs b/tests/LensTest.hs new file mode 100644 --- /dev/null +++ b/tests/LensTest.hs @@ -0,0 +1,36 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} + +module LensTest where + +import Control.Lens +import Test.HUnit +import TestRunner +import Util.Lens + +data Foo = Foo + { foo_bar :: Int + } + +defFoo :: Foo +defFoo = Foo { foo_bar = 42 } + +makeLowerCCLenses ''Foo + +readTest :: Test +readTest = TestLabel "read test" $ TestCase $ + assertEqual "foo bar baz" 43 (foo_bar $ adjust defFoo) + where + adjust = over fooBar (+ 1) + +main :: IO () +main = testRunner $ TestList + [ readTest + ] diff --git a/tests/ListTest.hs b/tests/ListTest.hs new file mode 100644 --- /dev/null +++ b/tests/ListTest.hs @@ -0,0 +1,50 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module ListTest (main) where + +import Test.QuickCheck +import Test.HUnit +import TestRunner +import Util.List + +main :: IO () +main = testRunner $ TestList + [ TestLabel "atMostChunksOf" $ TestCase $ do + result <- quickCheckResult prop_atMostChunksOf + case result of + Success{} -> return () + _ -> assertFailure "failed" + , TestLabel "chunkBy" $ TestCase $ do + result <- quickCheckResult prop_chunkBy + case result of + Success{} -> return () + _ -> assertFailure "failed" + ] + +prop_atMostChunksOf :: Int -> [Int] -> Bool +prop_atMostChunksOf n xs = + n <= 0 || null xs || + ( all ((<= n) . length) chunks + && all (not . null) chunks + && concat chunks == xs + && length chunks <= (length xs `div` n + 1) + ) + where + chunks = atMostChunksOf n xs + +prop_chunkBy :: Int -> [Int] -> Bool +prop_chunkBy n xs = + n <= 0 || null xs || + all ok chunks && concat chunks == xs + where + chunks = chunkBy n id xs + + ok [] = False + ok [_] = True + ok ys = sum ys <= n diff --git a/tests/MD5Test.hs b/tests/MD5Test.hs new file mode 100644 --- /dev/null +++ b/tests/MD5Test.hs @@ -0,0 +1,22 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module MD5Test (main) where + +import Test.HUnit +import TestRunner + +import Util.MD5 + +tests :: Test +tests = TestList + [ TestLabel "md5Test" $ TestCase $ + assertEqual "md5Test" (md5 "wibble") "50eccc6e2b0d307d5e8a40fb296f6171" ] + +main :: IO () +main = testRunner tests diff --git a/tests/MovingAverageRateLimiterTest.hs b/tests/MovingAverageRateLimiterTest.hs new file mode 100644 --- /dev/null +++ b/tests/MovingAverageRateLimiterTest.hs @@ -0,0 +1,91 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module MovingAverageRateLimiterTest (main) where + +import Data.List +import Test.HUnit +import TestRunner + +import Data.MovingAverageRateLimiter + +smoothRateLimiter :: Test +smoothRateLimiter = TestList + [ TestLabel "Smooth" $ TestCase $ assertEqual "allow 1qps" 0 fails + , TestLabel "Smooth" $ TestCase $ assertEqual "don't allow 2qps" False + (fst $ allow cfg rl' (fromIntegral sz)) + ] + where + sz = 50 :: Int + cfg = mkRateLimiterConfig 1.0 1.0 + rl = mkRateLimiter + go :: (RateLimiter, Int) -> Int -> (RateLimiter, Int) + go (r, f) now = + let (a, r') = allow cfg r (fromIntegral now) + in (r', f + fromEnum (not a)) + (rl', fails) = foldl' go (rl, 0) [1..sz] + +nonSmoothRateLimiter :: Test +nonSmoothRateLimiter = TestList + [ TestLabel "NonSmooth" $ TestCase $ assertEqual "allow 2qps" 0 fails + , TestLabel "NonSmooth" $ TestCase $ assertEqual "don't allow 3qps" False + (fst $ allow cfg rl' (fromIntegral sz)) + ] + where + sz = 1000 :: Int + cfg = mkRateLimiterConfig 2.01 10.0 + rl = mkRateLimiter + go :: (RateLimiter, Int) -> Int -> (RateLimiter, Int) + go (r, f) now = + let (a1, r1) = allow cfg r (fromIntegral now) + (a2, r2) = allow cfg r1 (fromIntegral now) + in (r2, f + fromEnum (not a1) + fromEnum (not a2)) + (rl', fails) = foldl' go (rl, 0) [1..sz] + +observedRateTest :: Test +observedRateTest = TestList + [ TestLabel "ObservedRate" $ TestCase $ + assertEqual "don't allow at 2" False a1 + , TestLabel "ObservedRate" $ TestCase $ + assertEqual "allow at 3" True a2 + ] + where + cfg = mkRateLimiterConfig 1.0 1.0 + rl = mkRateLimiter + rl2 = observedRate rl 1.01 2.0 + (a1, rl3) = allow cfg rl2 2 + (a2, _) = allow cfg rl3 3 + +qpsConverges :: Test +qpsConverges = TestList + [ TestLabel "constant" $ TestCase $ convergeTest 1.0 600.0 86400.0 + [ 0.0, 0.1 .. 86400.0 ] + , TestLabel "skip6hours" $ TestCase $ convergeTest 2.0 60.0 129600.0 $ + [ 0.0, 0.1 .. 21600.0] ++ [ 43200.0, 43200.1 .. 86400 ] + ] + +convergeTest :: Double -> Double -> Double -> [Double] -> Assertion +convergeTest qps0 hl expected bumps = do + putStrLn $ "Expected QPS: " ++ show expected + putStrLn $ "Got: " ++ show count + assertBool "converges on expected rate" closeEnough + where + cfg = mkRateLimiterConfig qps0 hl + go (r, n) t = + let (a, r') = allow cfg r t + in (r', n + fromEnum a) + (_, count) = foldl' go (mkRateLimiter, 0 :: Int) bumps + closeEnough = abs (fromIntegral count - expected) / expected < 0.01 + +main :: IO () +main = testRunner $ TestList + [ smoothRateLimiter + , nonSmoothRateLimiter + , observedRateTest + , qpsConverges + ] diff --git a/tests/OptParseTest.hs b/tests/OptParseTest.hs new file mode 100644 --- /dev/null +++ b/tests/OptParseTest.hs @@ -0,0 +1,70 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module OptParseTest where + +import Test.HUnit +import TestRunner + +import Data.Text (Text) +import Facebook.Init +import Options.Applicative +import Util.OptParse + +data Options = Options + { foo :: Text + , bar :: Int + } + +optionsParser :: Parser Options +optionsParser = Options + <$> textOption + ( long "foo" <> metavar "FOO" <> help "foo" ) + <*> intOption + ( long "bar" <> value 42 <> metavar "BAR" <> help "bar" ) + +optsInfo :: ParserInfo Options +optsInfo = info (helper <*> optionsParser) fullDesc + +partialTest :: Test +partialTest = TestLabel "partial" $ TestCase $ do + doTest -- only defined flags + [ "--foo=foo", "--bar=7" ] + [] + + doTest -- start with an unknown + [ "--baz=5", "--foo=foo", "--bar=7" ] + [ "--baz=5" ] + + doTest -- unknown in the middle + [ "--foo=foo", "--baz=5", "--bar=7" ] + [ "--baz=5" ] + + doTest -- end with an unknown + [ "--foo=foo", "--bar=7", "--baz=5" ] + [ "--baz=5" ] + + doTest -- intercalate known and unknown + [ "--snert=4", "--foo=foo", "--quux=wat", "--bar=7", "--baz=5" ] + [ "--snert=4", "--quux=wat", "--baz=5"] + + doTest -- `--` + [ "--foo=foo", "--baz=5", "--", "--bar=7", "--" ] + [ "--baz=5", "--bar=7", "--" ] + + where + doTest inp ex = do + (_, args) <- partialParse defaultPrefs optsInfo inp + assertEqual (show inp) ex args + + +main :: IO () +main = withFacebookUnitTest $ + testRunner $ TestList + [ partialTest + ] diff --git a/tests/RWVarTest.hs b/tests/RWVarTest.hs new file mode 100644 --- /dev/null +++ b/tests/RWVarTest.hs @@ -0,0 +1,82 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module RWVarTest (main) where + +import Test.HUnit +import TestRunner + +import Facebook.Init +import Util.RWVar +import Util.HUnit + +readTest :: Test +readTest = TestLabel "readTest" $ TestCase $ do + var <- newRWVar expected + withReadRWVar var $ \v -> + assertEqual "got expected back" expected v + where + expected = 'a' + +writeTest :: Test +writeTest = TestLabel "writeTest" $ TestCase $ do + var <- newRWVar initial + withWriteRWVar var $ \v -> do + assertEqual "got initial" initial v + return (update, ()) + withReadRWVar var $ \v -> + assertEqual "got updated value" update v + where + initial :: Int + initial = 42 + update = 1337 + +readReadTest :: Test +readReadTest = TestLabel "nestedReads" $ TestCase $ do + var <- newRWVar val + withReadRWVar var $ \x -> do + assertEqual "first got value" val x + withReadRWVar var $ \y -> + assertEqual "second got value" val y + where + val = 'a' + +readWriteDeadlockTest :: Test +readWriteDeadlockTest = TestLabel "read then write deadlocks" $ TestCase $ do + var <- newRWVar 'a' + assertThrow "deadlocks" $ + withReadRWVar var $ \_ -> + withWriteRWVar var $ \a -> return (a, ()) + +writeReadDeadlockTest :: Test +writeReadDeadlockTest = TestLabel "write then read deadlocks" $ TestCase $ do + var <- newRWVar 'a' + assertThrow "deadlocks" $ + withWriteRWVar var $ \a -> do + _ <- withReadRWVar var return + return (a, ()) + +writeWriteDeadlockTest :: Test +writeWriteDeadlockTest = TestLabel "write then write deadlocks" $ TestCase $ do + var <- newRWVar 'a' + assertThrow "deadlocks" $ + withWriteRWVar var $ \x -> do + _ <- withWriteRWVar var $ \y -> return (y, ()) + return (x, ()) + + +main :: IO () +main = withFacebookUnitTest $ + testRunner $ TestList + [ readTest + , writeTest + , readReadTest + , readWriteDeadlockTest + , writeReadDeadlockTest + , writeWriteDeadlockTest + ] diff --git a/tests/RateLimiterMapTest.hs b/tests/RateLimiterMapTest.hs new file mode 100644 --- /dev/null +++ b/tests/RateLimiterMapTest.hs @@ -0,0 +1,69 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module RateLimiterMapTest where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text, copy) + +import Data.RateLimiterMap + +import Test.HUnit +import TestRunner + +rlTest :: Assertion +rlTest = do + let reduceM z xs f = foldM f z xs + + crl <- newRateLimiterMapWithKeyPreprocessor 1 1 (return . copy) + -- 500 reqs to "foo" with 10 millisecond delay (100 qps for 5 secs) + (fooCount, _) <- + reduceM (0::Int, 0) [1..500] $ \ acc@(c,w) i -> do + threadDelay (10^(4::Int)) -- 10 milliseconds + allowed <- isAllowed crl "foo" + case allowed of + NotAllowed -> return acc + Allowed sw -> do + assertEqual "weight sum counts all" i (sw+w) + return (c+1, sw+w) + assertBool "was actually allowed" (fooCount > 0) + assertBool "was actually limited" (fooCount < 20) + +rlThreadedTest :: Assertion +rlThreadedTest = do + crl <- newRateLimiterMap 5 5 :: IO (RateLimiterMap Text) + mv <- newMVar (mempty :: HashMap Text (Int, SampleWeight)) + -- 50k reqs each to "foo" and "bar" from 100k threads, + -- requests come in bursts every quarter second for 5 secs + -- a test with 100k threads? sure why not + forConcurrently_ (zip [1..100000] $ cycle ["foo", "bar"]) $ \ (i, nm) -> do + threadDelay ((i `mod` 20) * 25 * 10^(4::Int)) + allowed <- isAllowed crl nm + case allowed of + NotAllowed -> return () + Allowed sw -> + modifyMVar_ mv $ + return . HashMap.insertWith (\(c',w') (c,w) -> (c+c', w+w')) nm (1,sw) + m <- takeMVar mv + let (fooCount,_) = HashMap.lookupDefault (0,0) "foo" m + (barCount,_) = HashMap.lookupDefault (0,0) "bar" m + assertBool "foo was allowed" (fooCount > 0) + assertBool "bar was allowed" (barCount > 0) + assertBool "foo was limited" (fooCount < 100) + assertBool "bar was limited" (barCount < 100) + +main :: IO () +main = testRunner $ TestList + [ TestLabel "RateLimiterMap" $ TestCase rlTest + , TestLabel "RateLimiterMapThreads" $ TestCase rlThreadedTest + ] diff --git a/tests/StreamTest.hs b/tests/StreamTest.hs new file mode 100644 --- /dev/null +++ b/tests/StreamTest.hs @@ -0,0 +1,70 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module StreamTest (main) where + +import Control.Concurrent +import Data.IORef +import Test.HUnit +import TestRunner + +import Facebook.Init +import Util.TimeSec + +import Control.Concurrent.Stream +import Data.List + +-- Run a worker that sleeps for 1 second over 10 elements. +-- Using 5 workers means we should finish in less than 10 seconds. +timingTest :: Bool -> Test +timingTest bound = TestLabel "timing" $ TestCase $ do + s <- now + count <- newIORef (0::Int) + let + producer add = mapM_ add [1..(10::Int)] + sleepy _ = do threadDelay 1000000; atomicModifyIORef' count (\i -> (i+1,())) + (if bound then streamBound else stream) 5 producer sleepy + e <- now + let (TimeSpan d) = timeDiff e s + assertBool "faster than sequential" (d < 5) + final <- readIORef count + assertEqual "all done" 10 final + +testMapConcurrently_unordered :: Test +testMapConcurrently_unordered = + TestLabel "mapConcurrently_unordered" $ TestCase $ do + let input = [0..9] + let expected = [1..10] + startTime <- now + output <- mapConcurrently_unordered + 10 (\x -> do threadDelay 1000000; pure (x + 1 :: Int)) input + endTime <- now + assertBool "Is faster than sequential" + (toSeconds (timeDiff endTime startTime) < 10) + assertBool "Received the expected output" + (expected == sort output) + +testMapForConcurrentlyEquivalent_unordered :: Test +testMapForConcurrentlyEquivalent_unordered = + TestLabel + "mapConcurrently_unordered==forConcurrently_unordered" $ TestCase $ do + let input = [0..9] + mapOut <- mapConcurrently_unordered 10 (\x -> pure $ x + (1 :: Int)) input + forOut <- forConcurrently_unordered 10 input (\x -> pure $ x + (1 :: Int)) + assertBool + "mapConcurrently_unordered and forConcurrently_unordered are equivalent" + (sort mapOut == sort forOut) + + +main :: IO () +main = withFacebookUnitTest $ testRunner $ TestList + [ timingTest True + , timingTest False + , testMapConcurrently_unordered + , testMapForConcurrentlyEquivalent_unordered + ] diff --git a/tests/StringQuasiTest.hs b/tests/StringQuasiTest.hs new file mode 100644 --- /dev/null +++ b/tests/StringQuasiTest.hs @@ -0,0 +1,26 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE QuasiQuotes #-} +module StringQuasiTest (main) where + +import Data.List + +import Test.HUnit +import TestRunner + +import Util.String.Quasi + +main :: IO () +main = testRunner $ TestList + [ TestLabel "util-string-quasi" . TestCase $ do + let str = [s| +this is a +multi-line string literal with \no escaping\|] + assertBool "util-string-quasi" ("\\no escaping\\" `isSuffixOf` str) + ] diff --git a/tests/THTest.hs b/tests/THTest.hs new file mode 100644 --- /dev/null +++ b/tests/THTest.hs @@ -0,0 +1,24 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE TemplateHaskell #-} + +module THTest (main) where + +import Test.HUnit +import TestRunner +import Language.Haskell.TH +import Util.MD5 + +tests :: Test +tests = TestList + [ TestLabel "th test" $ TestCase $ + assertEqual "th test" (md5 "dupa") $(runQ [| md5 "dupa" |]) ] + +main :: IO () +main = testRunner tests diff --git a/tests/TimeSecTest.hs b/tests/TimeSecTest.hs new file mode 100644 --- /dev/null +++ b/tests/TimeSecTest.hs @@ -0,0 +1,27 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module TimeSecTest (main) where + +import Test.HUnit +import TestRunner + +import Data.Aeson + +import Util.TimeSec + +jsonTest :: Test +jsonTest = TestLabel "Aeson instances" $ TestCase $ do + assertEqual "toJSON" (Number 123) (toJSON $ Time 123) + assertEqual "fromJSON" (eitherDecode "123") + (timeInSeconds <$> eitherDecode "123") + +main :: IO () +main = testRunner $ TestList + [ jsonTest + ] diff --git a/tests/ToExpTest.hs b/tests/ToExpTest.hs new file mode 100644 --- /dev/null +++ b/tests/ToExpTest.hs @@ -0,0 +1,60 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module ToExpTest where + +import Test.HUnit +import TestRunner + +import Data.Aeson ((.=), Value(Array, Number, Bool), object) +import qualified Data.Aeson as A +import Data.List +import qualified Data.Vector as Vector +import Util.ToExp + +tests :: Test +tests = TestList + [ TestLabel "numbers" $ TestCase $ do + assertEqual "int" + "3" + (pp (3 :: Int)) + assertEqual "negative int" + "(-7)" + (pp (-7 :: Int)) + assertEqual "negative double" + "(-7.0)" + (pp (-7.0 :: Double)) + assertEqual "negative number in " + "Just (-7)" + (pp (Just (-7) :: Maybe Int)) + , TestLabel "json" $ TestCase $ do + assertEqual "array" + "Array (Vector.fromList [Number (-3), Bool True, String \"foobarbaz\"])" + (pp $ Array $ Vector.fromList + [ Number (-3) + , Bool True + , A.String "foobarbaz" + ]) + assertEqual "object" + -- the result is non-deterministic. Rather than add the + -- overhead of sorting the elements all the time, let's just + -- sort the test output. +#if MIN_VERSION_aeson(2,0,0) + (sort "Object (fromList [(fromText \"foo\", Number (-3)), (fromText \"bar\", Bool True)])") +#else + (sort "Object (HashMap.fromList [(\"foo\", Number (-3)), (\"bar\", Bool True)])") +#endif + (sort $ pp $ object + [ "foo" .= Number (-3) + , "bar" .= Bool True + ]) + ] + +main :: IO () +main = testRunner tests diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests.hs @@ -0,0 +1,120 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +{-# LANGUAGE CPP #-} +module UnitTests (main) where + +import Test.HUnit +import TestRunner + +import Util.ByteString +import Util.Aeson +import qualified Util.Text as UT +import Data.Aeson.Types +import Data.Aeson (decode) +import Data.ByteString (packCString, packCStringLen, ByteString) + +import Foreign.Storable +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Array (advancePtr) +import Foreign.Ptr (nullPtr, Ptr) + +import TextShow + +intToByteStringTest :: Test +intToByteStringTest = TestCase $ do + assertEqual "min int" (intToByteString minBound) "-9223372036854775808" + assertEqual "max int" (intToByteString maxBound) "9223372036854775807" + assertEqual "zero" (intToByteString 0) "0" + +parseValueStrictTest :: Test +parseValueStrictTest = TestCase $ do + assertEqual "false" (Right $ Bool False) $ parseValueStrict' "false" + assertEqual "0.1" (Right $ Number 0.1) $ parseValueStrict' "0.1" + assertEqual "consume all input" (Left "endOfInput") $ + parseValueStrict' "falsee" + +#ifdef FACEBOOK +-- | We've patched the official aeson library to handle NaN. See #5183005 +-- This test ensures that we notice if we forget to patch on upgrade. +parseNaN :: Test +parseNaN = TestCase $ + case decode "[NaN]" of + Just [a :: Double] -> + assertBool "NaN" $ isNaN a + _ -> assertFailure "couldn't parse NaN" +#endif + +withCStringLenTest :: Test +withCStringLenTest = TestCase $ + UT.withCStringLen "Hello World" $ \(ptr, _) -> do + val <- peek ptr + assertEqual "first character" val (castCharToCChar 'H') + +useByteStringsAsCStringsTest :: Test +useByteStringsAsCStringsTest = TestCase $ + useByteStringsAsCStrings ["hello", "world"] $ \ptr -> do + hello <- packCString =<< peek ptr + world <- packCString =<< peek (advancePtr ptr 1) + term <- peek $ advancePtr ptr 2 + assertEqual "first word" hello "hello" + assertEqual "second word" world "world" + assertEqual "terminator" term nullPtr + +-- This should probably be a QuickCheck Property +bsListAsCStrLenArrTest :: [ByteString] -> Test +bsListAsCStrLenArrTest bs = TestCase $ + bsListAsCStrLenArr bs $ \strPtr lenPtr len -> do + let packBS :: CSize -> IO ByteString + packBS i = packCStringLen =<< (,) + <$> peek (getPtr strPtr) + <*> (fromIntegral <$> peek (getPtr lenPtr)) + where getPtr :: Storable a => Ptr a -> Ptr a + getPtr = (`advancePtr` fromIntegral i) + got <- mapM packBS [0..len - 1] + assertEqual "same list" got bs + +data MyEnum = MyA | MyB + deriving (Bounded, Enum, Eq, Show) + +instance UT.TextRead MyEnum +instance TextShow MyEnum where + showb MyA = "MyA" + showb MyB = "MyB" + +readTextTest :: Test +readTextTest = TestCase $ do + assertEqual "myA" (Just MyA) (UT.readText "MyA") + assertEqual "Nothing" (Nothing :: Maybe MyEnum) (UT.readText "MyC") + +insertCommasAndAndTest :: Test +insertCommasAndAndTest = TestCase $ do + assertEqual "null" "" $ UT.insertCommasAndAnd [] + assertEqual "singleton" "foo" $ UT.insertCommasAndAnd ["foo"] + assertEqual "pair" "foo and bar" $ UT.insertCommasAndAnd ["foo", "bar"] + assertEqual "triple" "foo, bar, and baz" $ + UT.insertCommasAndAnd ["foo", "bar", "baz"] + assertEqual "quad" "foo, bar, baz, and quux" $ + UT.insertCommasAndAnd ["foo", "bar", "baz", "quux"] + assertEqual "10" "1, 2, 3, 4, 5, 6, 7, 8, 9, and 10" $ + UT.insertCommasAndAnd [ showt (i::Int) | i <- [1..10] ] + +main :: IO () +main = testRunner $ TestList + [ TestLabel "intToByteString" intToByteStringTest + , TestLabel "parseValueStrictTest" parseValueStrictTest +#ifdef FACEBOOK + , TestLabel "parseNaN" parseNaN +#endif + , TestLabel "withCStringLen" withCStringLenTest + , TestLabel "useByteStringsAsCStrings" useByteStringsAsCStringsTest + , TestLabel "bsListAsCStrLenArr" (bsListAsCStrLenArrTest ["hello", "world"]) + , TestLabel "readText" readTextTest + , TestLabel "insertCommasAndAnd" insertCommasAndAndTest + ] diff --git a/tests/github/SpecRunner.hs b/tests/github/SpecRunner.hs new file mode 100644 --- /dev/null +++ b/tests/github/SpecRunner.hs @@ -0,0 +1,14 @@ +{- + Copyright (c) Meta Platforms, Inc. and affiliates. + All rights reserved. + + This source code is licensed under the BSD-style license found in the + LICENSE file in the root directory of this source tree. +-} + +module SpecRunner where + +import Test.Hspec + +specRunner :: Spec -> IO () +specRunner = hspec