{-# Language DeriveDataTypeable #-}
module Types
where
import Network.Mom.Stompl.Client.Queue
import Data.Time.Clock
import qualified Data.ByteString.Char8 as B
import Data.Typeable (Typeable)
import Control.Exception (throwIO,
Exception, SomeException, Handler(..),
AsyncException(..),
bracket, finally)
import Control.Concurrent
import Control.Monad (void)
data StatusCode = OK | BadRequest | Forbidden | NotFound | Timeout
deriving (StatusCode -> StatusCode -> Bool
(StatusCode -> StatusCode -> Bool)
-> (StatusCode -> StatusCode -> Bool) -> Eq StatusCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StatusCode -> StatusCode -> Bool
$c/= :: StatusCode -> StatusCode -> Bool
== :: StatusCode -> StatusCode -> Bool
$c== :: StatusCode -> StatusCode -> Bool
Eq)
instance Show StatusCode where
show :: StatusCode -> String
show StatusCode
OK = String
"200"
show StatusCode
BadRequest = String
"400"
show StatusCode
Forbidden = String
"403"
show StatusCode
NotFound = String
"404"
show StatusCode
Timeout = String
"408"
instance Read StatusCode where
readsPrec :: Int -> ReadS StatusCode
readsPrec Int
_ String
r = case String
r of
String
"200" -> [(StatusCode
OK,String
"")]
String
"400" -> [(StatusCode
BadRequest,String
"")]
String
"403" -> [(StatusCode
Forbidden,String
"")]
String
"404" -> [(StatusCode
NotFound,String
"")]
String
"408" -> [(StatusCode
Timeout,String
"")]
String
_ -> [(StatusCode, String)]
forall a. HasCallStack => a
undefined
readStatusCode :: String -> Either String StatusCode
readStatusCode :: String -> Either String StatusCode
readStatusCode String
s = case String
s of
String
"200" -> StatusCode -> Either String StatusCode
forall a b. b -> Either a b
Right StatusCode
OK
String
"400" -> StatusCode -> Either String StatusCode
forall a b. b -> Either a b
Right StatusCode
BadRequest
String
"403" -> StatusCode -> Either String StatusCode
forall a b. b -> Either a b
Right StatusCode
Forbidden
String
"404" -> StatusCode -> Either String StatusCode
forall a b. b -> Either a b
Right StatusCode
NotFound
String
"408" -> StatusCode -> Either String StatusCode
forall a b. b -> Either a b
Right StatusCode
Timeout
String
_ -> String -> Either String StatusCode
forall a b. a -> Either a b
Left (String -> Either String StatusCode)
-> String -> Either String StatusCode
forall a b. (a -> b) -> a -> b
$ String
"Unknown status code: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
type JobName = String
type QName = String
nobody :: OutBound ()
nobody :: OutBound ()
nobody ()
_ = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
ignorebody :: InBound ()
ignorebody :: InBound ()
ignorebody Type
_ Int
_ [Header]
_ ByteString
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
bytesOut :: OutBound B.ByteString
bytesOut :: ByteString -> IO ByteString
bytesOut = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
bytesIn :: InBound B.ByteString
bytesIn :: InBound ByteString
bytesIn Type
_ Int
_ [Header]
_ = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
reThrowHandler :: String -> OnError -> [Handler a]
reThrowHandler :: String -> OnError -> [Handler a]
reThrowHandler String
s OnError
onErr = [
(AsyncException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\AsyncException
e -> AsyncException -> IO a
forall e a. Exception e => e -> IO a
throwIO (AsyncException
e::AsyncException)),
(SomeException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\SomeException
e -> OnError
onErr SomeException
e String
s IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
e)]
ignoreHandler :: String -> OnError -> [Handler ()]
ignoreHandler :: String -> OnError -> [Handler ()]
ignoreHandler String
s OnError
onErr = [
(AsyncException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\AsyncException
e -> AsyncException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (AsyncException
e::AsyncException)),
(SomeException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\SomeException
e -> OnError
onErr SomeException
e String
s)]
killAndWait :: MVar () -> ThreadId -> IO ()
killAndWait :: MVar () -> ThreadId -> IO ()
killAndWait MVar ()
m ThreadId
tid = do ThreadId -> IO ()
killThread ThreadId
tid
IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
m
withThread :: IO () -> IO r -> IO r
withThread :: IO () -> IO r -> IO r
withThread IO ()
thrd IO r
action = do
MVar ()
stp <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
IO ThreadId -> (ThreadId -> IO ()) -> (ThreadId -> IO r) -> IO r
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally IO ()
thrd (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
stp ()))
(MVar () -> ThreadId -> IO ()
killAndWait MVar ()
stp)
(\ThreadId
_ -> IO r
action)
data PatternsException =
TimeoutX String
| BadStatusCodeX String
| NotOKX StatusCode String
| String String
| MissingHbX String
| UnacceptableHbX Int
| NoProviderX String
| AppX String
deriving (Int -> PatternsException -> ShowS
[PatternsException] -> ShowS
PatternsException -> String
(Int -> PatternsException -> ShowS)
-> (PatternsException -> String)
-> ([PatternsException] -> ShowS)
-> Show PatternsException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PatternsException] -> ShowS
$cshowList :: [PatternsException] -> ShowS
show :: PatternsException -> String
$cshow :: PatternsException -> String
showsPrec :: Int -> PatternsException -> ShowS
$cshowsPrec :: Int -> PatternsException -> ShowS
Show, ReadPrec [PatternsException]
ReadPrec PatternsException
Int -> ReadS PatternsException
ReadS [PatternsException]
(Int -> ReadS PatternsException)
-> ReadS [PatternsException]
-> ReadPrec PatternsException
-> ReadPrec [PatternsException]
-> Read PatternsException
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PatternsException]
$creadListPrec :: ReadPrec [PatternsException]
readPrec :: ReadPrec PatternsException
$creadPrec :: ReadPrec PatternsException
readList :: ReadS [PatternsException]
$creadList :: ReadS [PatternsException]
readsPrec :: Int -> ReadS PatternsException
$creadsPrec :: Int -> ReadS PatternsException
Read, Typeable, PatternsException -> PatternsException -> Bool
(PatternsException -> PatternsException -> Bool)
-> (PatternsException -> PatternsException -> Bool)
-> Eq PatternsException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PatternsException -> PatternsException -> Bool
$c/= :: PatternsException -> PatternsException -> Bool
== :: PatternsException -> PatternsException -> Bool
$c== :: PatternsException -> PatternsException -> Bool
Eq)
instance Exception PatternsException
type OnError = SomeException -> String -> IO ()
data HB = HB {
HB -> Int
hbMe :: Int,
HB -> UTCTime
hbMeNext :: UTCTime
}
mkHB :: Int -> IO HB
mkHB :: Int -> IO HB
mkHB Int
me = do
UTCTime
now <- IO UTCTime
getCurrentTime
HB -> IO HB
forall (m :: * -> *) a. Monad m => a -> m a
return HB :: Int -> UTCTime -> HB
HB {
hbMe :: Int
hbMe = Int
me,
hbMeNext :: UTCTime
hbMeNext = UTCTime -> Int -> UTCTime
timeAdd UTCTime
now Int
me}
tolerance :: Int
tolerance :: Int
tolerance = Int
10
nextHB :: UTCTime -> Bool -> Int -> UTCTime
nextHB :: UTCTime -> Bool -> Int -> UTCTime
nextHB UTCTime
now Bool
t Int
p = let tol :: Int
tol = if Bool
t then Int
tolerance else Int
1
in UTCTime -> Int -> UTCTime
timeAdd UTCTime
now (Int -> UTCTime) -> Int -> UTCTime
forall a b. (a -> b) -> a -> b
$ Int
tol Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
p
timeAdd :: UTCTime -> Int -> UTCTime
timeAdd :: UTCTime -> Int -> UTCTime
timeAdd UTCTime
t Int
p = Int -> NominalDiffTime
ms2nominal Int
p NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
t
ms2nominal :: Int -> NominalDiffTime
ms2nominal :: Int -> NominalDiffTime
ms2nominal Int
m = Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ (NominalDiffTime
1000::NominalDiffTime)
nominal2us :: NominalDiffTime -> Int
nominal2us :: NominalDiffTime -> Int
nominal2us NominalDiffTime
m = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
fact Double -> Double -> Double
forall a. Num a => a -> a -> a
* NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
m :: Double)
where fact :: Double
fact = Double
10.0Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6::Int)