{-# 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)


  ------------------------------------------------------------------------
  -- | Status code to communicate the state of a request
  --   between two applications. 
  --   The wire format is inspired by HTTP status codes:
  --
  --   * OK (200): Everything is fine
  --
  --   * BadRequest (400): Syntax error in the request message
  --
  --   * Forbidden (403): Not used
  --
  --   * NotFound (404): For the requested job no provider is available
  --
  --   * Timeout (408): Timeout expired
  ------------------------------------------------------------------------
  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
                      
  ------------------------------------------------------------------------
  -- | Safe StatusCode parser 
  --   ('StatusCode' is instance of 'Read',
  --    but 'read' would cause an error on an invalid StatusCode)
  ------------------------------------------------------------------------
  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

  -- | Name of a service, task or topic
  type JobName = String

  -- | Name of a Stomp queue
  type QName   = String

  -- | OutBound converter for messages of type ()
  nobody     :: OutBound ()
  nobody :: OutBound ()
nobody ()
_ = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty

  -- | InBound converter for messages of type ()
  ignorebody :: InBound ()
  ignorebody :: InBound ()
ignorebody Type
_ Int
_ [Header]
_ ByteString
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- | OutBound converter for messages of type 'B.ByteString'
  bytesOut :: OutBound B.ByteString
  bytesOut :: ByteString -> IO ByteString
bytesOut = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return

  -- | InBound converter for messages of type 'B.ByteString'
  bytesIn :: InBound B.ByteString
  bytesIn :: InBound ByteString
bytesIn Type
_ Int
_ [Header]
_ = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return

  -----------------------------------------------------------------------
  -- Error and Exception
  -----------------------------------------------------------------------
  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)

  ------------------------------------------------------------------------
  -- | Patterns Exception
  ------------------------------------------------------------------------
  data PatternsException = 
                         -- | Timout expired
                         TimeoutX            String
                         -- | Invalid status code 
                         | BadStatusCodeX    String
                         -- | Status code other than OK
                         | NotOKX StatusCode String
                         -- | Error on Header identified by the first String
                         | HeaderX String    String
                         -- | Thrown on missing heartbeat 
                         --   (after tolerance of 10 missing heartbeats)
                         | MissingHbX        String
                         -- | Heartbeat proposed by registry
                         --   out of acceptable range
                         | UnacceptableHbX   Int
                         -- | No provider for the requested job available
                         | NoProviderX       String
                         -- | Application-defined exception
                         | 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

  ------------------------------------------------------------------------
  -- | Error Handler:
  --
  --   * 'SomeException': Exception that led the invocation;
  --
  --   * String: Name of the entity (client name, server name, /etc./)
  ------------------------------------------------------------------------
  type OnError  = SomeException -> String -> IO ()

  ------------------------------------------------------------------------
  -- | Heartbeat controller type
  ------------------------------------------------------------------------
  data HB = HB {
              HB -> Int
hbMe     :: Int,
              HB -> UTCTime
hbMeNext :: UTCTime
            }
  
  ------------------------------------------------------------------------
  -- | Create a heartbeat controller;
  --   receives the heartbeat in milliseconds.
  ------------------------------------------------------------------------
  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}

  -- HB tolerance 
  tolerance :: Int
  tolerance :: Int
tolerance = Int
10

  ------------------------------------------------------------------------
  -- Comput the next hearbeat from current one
  ------------------------------------------------------------------------
  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

  -----------------------------------------------------------------------
  -- Adding a period to a point in time
  -----------------------------------------------------------------------
  timeAdd :: UTCTime -> Int -> UTCTime
  timeAdd :: UTCTime -> Int -> UTCTime
timeAdd UTCTime
t Int
p = Int -> NominalDiffTime
ms2nominal Int
p NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
t

  -----------------------------------------------------------------------
  -- Convert milliseconds to seconds
  -----------------------------------------------------------------------
  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)

  -----------------------------------------------------------------------
  -- Convert 'NominalDiffTime' to microseconds
  -----------------------------------------------------------------------
  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)