mongodb/Database/MongoDB/Util.hs

66 lines
2.1 KiB
Haskell
Raw Normal View History

-- | Miscellaneous general functions
2010-01-17 01:22:05 +00:00
{-# LANGUAGE StandaloneDeriving #-}
2010-01-17 01:22:05 +00:00
module Database.MongoDB.Util where
2010-01-17 01:22:05 +00:00
import Prelude hiding (length)
import Network (PortID(..))
import Control.Applicative (Applicative(..), (<$>))
import Control.Exception (assert)
import Control.Monad.Reader
import Control.Monad.Error
import Data.UString as U (UString, cons, append)
import Data.Bits (Bits, (.|.))
import Data.Bson
import System.IO (Handle)
import Data.ByteString.Lazy as B (ByteString, length, append, hGet)
deriving instance Show PortID
deriving instance Eq PortID
deriving instance Ord PortID
instance (Monad m) => Applicative (ReaderT r m) where
pure = return
(<*>) = ap
instance (Monad m, Error e) => Applicative (ErrorT e m) where
pure = return
(<*>) = ap
ignore :: (Monad m) => a -> m ()
ignore _ = return ()
type Secs = Float
bitOr :: (Bits a) => [a] -> a
-- ^ bit-or all numbers together
bitOr = foldl (.|.) 0
(<.>) :: UString -> UString -> UString
-- ^ Concat first and second together with period in between. Eg. @\"hello\" \<.\> \"world\" = \"hello.world\"@
a <.> b = U.append a (cons '.' b)
loop :: (Functor m, Monad m) => m (Maybe a) -> m [a]
-- ^ Repeatedy execute action, collecting results, until it returns Nothing
loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act)
true1 :: Label -> Document -> Bool
-- ^ Is field's value a 1 or True (MongoDB use both Int and Bools for truth values). Error if field not in document or field not a Num or Bool.
true1 k doc = case valueAt k doc of
Bool b -> b
Float n -> n == 1
Int32 n -> n == 1
Int64 n -> n == 1
_ -> error $ "expected " ++ show k ++ " to be Num or Bool in " ++ show doc
hGetN :: Handle -> Int -> IO ByteString
-- ^ Read N bytes from hande, blocking until all N bytes are read.
-- Unlike hGet which only blocks if no bytes are available, otherwise it returns the X bytes immediately available where X <= N.
hGetN h n = assert (n >= 0) $ do
bytes <- hGet h n
let x = fromIntegral (length bytes)
if x >= n then return bytes else do
remainingBytes <- hGetN h (n - x)
return (B.append bytes remainingBytes)