{-# Language BangPatterns #-}
module Registry
where
import Types
import Network.Mom.Stompl.Client.Queue
import System.Timeout
import Data.Time
import Data.Char (isDigit, toUpper)
import Data.List (nub)
import Data.Maybe (fromMaybe)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Sequence (Seq, (|>), (<|), ViewL(..))
import qualified Data.Sequence as S
import Data.Foldable (toList)
import Codec.MIME.Type (nullType)
import Control.Exception (throwIO, catches)
import Control.Concurrent
import Control.Monad (forever)
import Control.Applicative ((<$>))
data JobType = Service | Task | Topic
deriving (JobType -> JobType -> Bool
(JobType -> JobType -> Bool)
-> (JobType -> JobType -> Bool) -> Eq JobType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JobType -> JobType -> Bool
$c/= :: JobType -> JobType -> Bool
== :: JobType -> JobType -> Bool
$c== :: JobType -> JobType -> Bool
Eq, Int -> JobType -> ShowS
[JobType] -> ShowS
JobType -> String
(Int -> JobType -> ShowS)
-> (JobType -> String) -> ([JobType] -> ShowS) -> Show JobType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JobType] -> ShowS
$cshowList :: [JobType] -> ShowS
show :: JobType -> String
$cshow :: JobType -> String
showsPrec :: Int -> JobType -> ShowS
$cshowsPrec :: Int -> JobType -> ShowS
Show)
readJobType :: String -> Maybe JobType
readJobType :: String -> Maybe JobType
readJobType String
s =
case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
s of
String
"SERVICE" -> JobType -> Maybe JobType
forall a. a -> Maybe a
Just JobType
Service
String
"TASK" -> JobType -> Maybe JobType
forall a. a -> Maybe a
Just JobType
Task
String
"TOPIC" -> JobType -> Maybe JobType
forall a. a -> Maybe a
Just JobType
Topic
String
_ -> Maybe JobType
forall a. Maybe a
Nothing
type RegistryDesc = (QName, Int, (Int, Int, Int))
register :: Con -> JobName -> JobType ->
QName -> QName ->
Int -> Int -> IO (StatusCode, Int)
register :: Con
-> String
-> JobType
-> String
-> String
-> Int
-> Int
-> IO (StatusCode, Int)
register Con
c String
j JobType
t String
o String
i Int
to Int
me | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
j = (StatusCode, Int) -> IO (StatusCode, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (StatusCode
BadRequest,Int
0)
| Bool
otherwise =
let i' :: String
i' = String
o String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
j String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i
hs :: [(String, String)]
hs = [(String
"__type__", String
"register"),
(String
"__job-type__", JobType -> String
forall a. Show a => a -> String
show JobType
t),
(String
"__job__", String
j),
(String
"__queue__", String
i),
(String
"__hb__", Int -> String
forall a. Show a => a -> String
show Int
me),
(String
"__channel__", String
i')]
in Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> OutBound ()
-> (Writer () -> IO (StatusCode, Int))
-> IO (StatusCode, Int)
forall o r.
Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> OutBound o
-> (Writer o -> IO r)
-> IO r
withWriter Con
c String
"RegistryW" String
o [] [] OutBound ()
nobody ((Writer () -> IO (StatusCode, Int)) -> IO (StatusCode, Int))
-> (Writer () -> IO (StatusCode, Int)) -> IO (StatusCode, Int)
forall a b. (a -> b) -> a -> b
$ \Writer ()
w ->
Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> InBound ()
-> (Reader () -> IO (StatusCode, Int))
-> IO (StatusCode, Int)
forall i r.
Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> InBound i
-> (Reader i -> IO r)
-> IO r
withReader Con
c String
"RegistryR" String
i' [] [] InBound ()
ignorebody ((Reader () -> IO (StatusCode, Int)) -> IO (StatusCode, Int))
-> (Reader () -> IO (StatusCode, Int)) -> IO (StatusCode, Int)
forall a b. (a -> b) -> a -> b
$ \Reader ()
r -> do
Writer () -> Type -> [(String, String)] -> () -> IO ()
forall a. Writer a -> Type -> [(String, String)] -> a -> IO ()
writeQ Writer ()
w Type
nullType [(String, String)]
hs ()
Maybe (Message ())
mbF <- Int -> IO (Message ()) -> IO (Maybe (Message ()))
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
to (IO (Message ()) -> IO (Maybe (Message ())))
-> IO (Message ()) -> IO (Maybe (Message ()))
forall a b. (a -> b) -> a -> b
$ Reader () -> IO (Message ())
forall a. Reader a -> IO (Message a)
readQ Reader ()
r
case Maybe (Message ())
mbF of
Maybe (Message ())
Nothing -> PatternsException -> IO (StatusCode, Int)
forall e a. Exception e => e -> IO a
throwIO (PatternsException -> IO (StatusCode, Int))
-> PatternsException -> IO (StatusCode, Int)
forall a b. (a -> b) -> a -> b
$ String -> PatternsException
TimeoutX
String
"No response from registry"
Just Message ()
m -> do Either String StatusCode
eiS <- Message () -> IO (Either String StatusCode)
forall m. Message m -> IO (Either String StatusCode)
getSC Message ()
m
case Either String StatusCode
eiS of
Left String
s -> PatternsException -> IO (StatusCode, Int)
forall e a. Exception e => e -> IO a
throwIO (PatternsException -> IO (StatusCode, Int))
-> PatternsException -> IO (StatusCode, Int)
forall a b. (a -> b) -> a -> b
$ String -> PatternsException
BadStatusCodeX String
s
Right StatusCode
OK -> do Int
h <- Message () -> IO Int
forall m. Message m -> IO Int
getHB Message ()
m
(StatusCode, Int) -> IO (StatusCode, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (StatusCode
OK, Int
h)
Right StatusCode
sc -> (StatusCode, Int) -> IO (StatusCode, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (StatusCode
sc, Int
0)
unRegister :: Con -> JobName ->
QName -> QName ->
Int -> IO StatusCode
unRegister :: Con -> String -> String -> String -> Int -> IO StatusCode
unRegister Con
c String
j String
o String
i Int
tmo | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
j = StatusCode -> IO StatusCode
forall (m :: * -> *) a. Monad m => a -> m a
return StatusCode
BadRequest
| Bool
otherwise =
let i' :: String
i' = String
o String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
j String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i
hs :: [(String, String)]
hs = [(String
"__type__", String
"unreg"),
(String
"__job__", String
j),
(String
"__queue__", String
i),
(String
"__channel__", String
i')]
in Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> OutBound ()
-> (Writer () -> IO StatusCode)
-> IO StatusCode
forall o r.
Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> OutBound o
-> (Writer o -> IO r)
-> IO r
withWriter Con
c String
"RegistryW" String
o [] [] OutBound ()
nobody ((Writer () -> IO StatusCode) -> IO StatusCode)
-> (Writer () -> IO StatusCode) -> IO StatusCode
forall a b. (a -> b) -> a -> b
$ \Writer ()
w ->
Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> InBound ()
-> (Reader () -> IO StatusCode)
-> IO StatusCode
forall i r.
Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> InBound i
-> (Reader i -> IO r)
-> IO r
withReader Con
c String
"RegistryR" String
i' [] [] InBound ()
ignorebody ((Reader () -> IO StatusCode) -> IO StatusCode)
-> (Reader () -> IO StatusCode) -> IO StatusCode
forall a b. (a -> b) -> a -> b
$ \Reader ()
r -> do
Writer () -> Type -> [(String, String)] -> () -> IO ()
forall a. Writer a -> Type -> [(String, String)] -> a -> IO ()
writeQ Writer ()
w Type
nullType [(String, String)]
hs ()
Maybe (Message ())
mbF <- Int -> IO (Message ()) -> IO (Maybe (Message ()))
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
tmo (IO (Message ()) -> IO (Maybe (Message ())))
-> IO (Message ()) -> IO (Maybe (Message ()))
forall a b. (a -> b) -> a -> b
$ Reader () -> IO (Message ())
forall a. Reader a -> IO (Message a)
readQ Reader ()
r
case Maybe (Message ())
mbF of
Maybe (Message ())
Nothing -> PatternsException -> IO StatusCode
forall e a. Exception e => e -> IO a
throwIO (PatternsException -> IO StatusCode)
-> PatternsException -> IO StatusCode
forall a b. (a -> b) -> a -> b
$ String -> PatternsException
TimeoutX String
"No response from register"
Just Message ()
m -> do Either String StatusCode
eiS <- Message () -> IO (Either String StatusCode)
forall m. Message m -> IO (Either String StatusCode)
getSC Message ()
m
case Either String StatusCode
eiS of
Left String
s -> PatternsException -> IO StatusCode
forall e a. Exception e => e -> IO a
throwIO (PatternsException -> IO StatusCode)
-> PatternsException -> IO StatusCode
forall a b. (a -> b) -> a -> b
$ String -> PatternsException
BadStatusCodeX String
s
Right StatusCode
sc -> StatusCode -> IO StatusCode
forall (m :: * -> *) a. Monad m => a -> m a
return StatusCode
sc
heartbeat :: MVar HB -> Writer () -> JobName -> QName -> IO ()
heartbeat :: MVar HB -> Writer () -> String -> String -> IO ()
heartbeat MVar HB
m Writer ()
w String
j String
q | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
q = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise =
let hs :: [(String, String)]
hs = [(String
"__type__", String
"hb"),
(String
"__job__", String
j),
(String
"__queue__", String
q)]
in do UTCTime
now <- IO UTCTime
getCurrentTime
MVar HB -> (HB -> IO HB) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar HB
m (UTCTime -> [(String, String)] -> HB -> IO HB
go UTCTime
now [(String, String)]
hs)
where go :: UTCTime -> [(String, String)] -> HB -> IO HB
go UTCTime
now [(String, String)]
hs hb :: HB
hb@(HB Int
me UTCTime
nxt)
| Int
me Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& UTCTime
nxt UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now = do Writer () -> Type -> [(String, String)] -> () -> IO ()
forall a. Writer a -> Type -> [(String, String)] -> a -> IO ()
writeQ Writer ()
w Type
nullType [(String, String)]
hs ()
HB -> IO HB
forall (m :: * -> *) a. Monad m => a -> m a
return HB
hb{hbMeNext :: UTCTime
hbMeNext = UTCTime -> Int -> UTCTime
timeAdd UTCTime
now Int
me}
| Bool
otherwise = HB -> IO HB
forall (m :: * -> *) a. Monad m => a -> m a
return HB
hb
data Provider = Provider {
Provider -> String
prvQ :: QName,
Provider -> Int
prvHb :: Int,
Provider -> UTCTime
prvNxt :: UTCTime
}
deriving Int -> Provider -> ShowS
[Provider] -> ShowS
Provider -> String
(Int -> Provider -> ShowS)
-> (Provider -> String) -> ([Provider] -> ShowS) -> Show Provider
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Provider] -> ShowS
$cshowList :: [Provider] -> ShowS
show :: Provider -> String
$cshow :: Provider -> String
showsPrec :: Int -> Provider -> ShowS
$cshowsPrec :: Int -> Provider -> ShowS
Show
instance Eq Provider where
Provider
x == :: Provider -> Provider -> Bool
== Provider
y = Provider -> String
prvQ Provider
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Provider -> String
prvQ Provider
y
updOrAddProv :: Bool -> (Provider -> Provider) -> Provider ->
Seq Provider -> Seq Provider
updOrAddProv :: Bool
-> (Provider -> Provider)
-> Provider
-> Seq Provider
-> Seq Provider
updOrAddProv Bool
add Provider -> Provider
upd Provider
p Seq Provider
s =
case Seq Provider -> ViewL Provider
forall a. Seq a -> ViewL a
S.viewl Seq Provider
s of
ViewL Provider
S.EmptyL -> if Bool
add then Provider -> Seq Provider
forall a. a -> Seq a
S.singleton Provider
p else Seq Provider
forall a. Seq a
S.empty
Provider
x :< Seq Provider
ss -> if Provider -> String
prvQ Provider
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Provider -> String
prvQ Provider
p
then Provider -> Provider
upd Provider
x Provider -> Seq Provider -> Seq Provider
forall a. a -> Seq a -> Seq a
<| Seq Provider
ss
else Provider
x Provider -> Seq Provider -> Seq Provider
forall a. a -> Seq a -> Seq a
<| Bool
-> (Provider -> Provider)
-> Provider
-> Seq Provider
-> Seq Provider
updOrAddProv Bool
add Provider -> Provider
upd Provider
p Seq Provider
ss
remProv :: QName -> Seq Provider -> Seq Provider
remProv :: String -> Seq Provider -> Seq Provider
remProv String
q Seq Provider
s =
case Seq Provider -> ViewL Provider
forall a. Seq a -> ViewL a
S.viewl Seq Provider
s of
ViewL Provider
S.EmptyL -> Seq Provider
forall a. Seq a
S.empty
Provider
x :< Seq Provider
ss -> if Provider -> String
prvQ Provider
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
q then Seq Provider
ss
else Provider
x Provider -> Seq Provider -> Seq Provider
forall a. a -> Seq a -> Seq a
<| String -> Seq Provider -> Seq Provider
remProv String
q Seq Provider
ss
getHeads :: UTCTime -> Seq Provider -> ([Provider], Seq Provider)
getHeads :: UTCTime -> Seq Provider -> ([Provider], Seq Provider)
getHeads UTCTime
now Seq Provider
s =
case Seq Provider -> ViewL Provider
forall a. Seq a -> ViewL a
S.viewl Seq Provider
s of
ViewL Provider
S.EmptyL -> ([], Seq Provider
forall a. Seq a
S.empty)
Provider
x :< Seq Provider
ss -> if Provider -> Int
prvHb Provider
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&&
Provider -> UTCTime
prvNxt Provider
x UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now then UTCTime -> Seq Provider -> ([Provider], Seq Provider)
getHeads UTCTime
now Seq Provider
ss
else ([Provider
x], Seq Provider
ss Seq Provider -> Provider -> Seq Provider
forall a. Seq a -> a -> Seq a
|> Provider
x)
data JobNode = JobNode {
JobNode -> JobType
jobType :: JobType,
JobNode -> Seq Provider
jobProvs :: Seq Provider
}
data Reg = Reg {
Reg -> String
regName :: String,
Reg -> Map String JobNode
regWork :: Map JobName JobNode
}
data Registry = Registry {
Registry -> MVar Reg
regM :: MVar Reg
}
useRegistry :: Registry -> (Reg -> IO (Reg, r)) -> IO r
useRegistry :: Registry -> (Reg -> IO (Reg, r)) -> IO r
useRegistry Registry
r = MVar Reg -> (Reg -> IO (Reg, r)) -> IO r
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (Registry -> MVar Reg
regM Registry
r)
useRegistry_ :: Registry -> (Reg -> IO Reg) -> IO ()
useRegistry_ :: Registry -> (Reg -> IO Reg) -> IO ()
useRegistry_ Registry
r = MVar Reg -> (Reg -> IO Reg) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Registry -> MVar Reg
regM Registry
r)
insertR :: Registry -> JobName -> JobType -> QName -> Int -> IO ()
insertR :: Registry -> String -> JobType -> String -> Int -> IO ()
insertR Registry
r String
jn JobType
w String
qn Int
i =
Registry -> (Reg -> IO Reg) -> IO ()
useRegistry_ Registry
r ((Reg -> IO Reg) -> IO ()) -> (Reg -> IO Reg) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Reg
reg -> do UTCTime
now <- IO UTCTime
getCurrentTime
Reg -> IO Reg
forall (m :: * -> *) a. Monad m => a -> m a
return Reg
reg{regWork :: Map String JobNode
regWork = UTCTime -> Map String JobNode -> Map String JobNode
ins UTCTime
now (Map String JobNode -> Map String JobNode)
-> Map String JobNode -> Map String JobNode
forall a b. (a -> b) -> a -> b
$ Reg -> Map String JobNode
regWork Reg
reg}
where ins :: UTCTime -> Map String JobNode -> Map String JobNode
ins UTCTime
now Map String JobNode
m =
let j :: JobNode
j = JobNode -> Maybe JobNode -> JobNode
forall a. a -> Maybe a -> a
fromMaybe (JobType -> Seq Provider -> JobNode
JobNode JobType
w Seq Provider
forall a. Seq a
S.empty) (Maybe JobNode -> JobNode) -> Maybe JobNode -> JobNode
forall a b. (a -> b) -> a -> b
$ String -> Map String JobNode -> Maybe JobNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
jn Map String JobNode
m
p :: Provider
p = String -> Int -> UTCTime -> Provider
Provider String
qn Int
i (UTCTime -> Provider) -> UTCTime -> Provider
forall a b. (a -> b) -> a -> b
$ UTCTime -> Bool -> Int -> UTCTime
nextHB UTCTime
now Bool
True Int
i
ps :: Seq Provider
ps = Bool
-> (Provider -> Provider)
-> Provider
-> Seq Provider
-> Seq Provider
updOrAddProv Bool
True (Provider -> Provider -> Provider
forall p p. p -> p -> p
upd Provider
p) Provider
p (Seq Provider -> Seq Provider) -> Seq Provider -> Seq Provider
forall a b. (a -> b) -> a -> b
$ JobNode -> Seq Provider
jobProvs JobNode
j
in String -> JobNode -> Map String JobNode -> Map String JobNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
jn JobNode
j{jobProvs :: Seq Provider
jobProvs = Seq Provider
ps} Map String JobNode
m
upd :: p -> p -> p
upd p
n p
_ = p
n
updR :: Registry -> JobName -> QName -> IO ()
updR :: Registry -> String -> String -> IO ()
updR Registry
r String
jn String
qn =
Registry -> (Reg -> IO Reg) -> IO ()
useRegistry_ Registry
r ((Reg -> IO Reg) -> IO ()) -> (Reg -> IO Reg) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Reg
reg -> do UTCTime
now <- IO UTCTime
getCurrentTime
Reg -> IO Reg
forall (m :: * -> *) a. Monad m => a -> m a
return Reg
reg{regWork :: Map String JobNode
regWork = UTCTime -> Map String JobNode -> Map String JobNode
ins UTCTime
now (Map String JobNode -> Map String JobNode)
-> Map String JobNode -> Map String JobNode
forall a b. (a -> b) -> a -> b
$ Reg -> Map String JobNode
regWork Reg
reg}
where ins :: UTCTime -> Map String JobNode -> Map String JobNode
ins UTCTime
now Map String JobNode
m =
case String -> Map String JobNode -> Maybe JobNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
jn Map String JobNode
m of
Maybe JobNode
Nothing -> Map String JobNode
m
Just JobNode
j -> let p :: Provider
p = String -> Int -> UTCTime -> Provider
Provider String
qn Int
0 UTCTime
now
ps :: Seq Provider
ps = Bool
-> (Provider -> Provider)
-> Provider
-> Seq Provider
-> Seq Provider
updOrAddProv Bool
False (UTCTime -> Provider -> Provider
upd UTCTime
now) Provider
p
(JobNode -> Seq Provider
jobProvs JobNode
j)
in String -> JobNode -> Map String JobNode -> Map String JobNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
jn JobNode
j{jobProvs :: Seq Provider
jobProvs = Seq Provider
ps} Map String JobNode
m
upd :: UTCTime -> Provider -> Provider
upd UTCTime
now Provider
o = Provider
o{prvNxt :: UTCTime
prvNxt = UTCTime -> Bool -> Int -> UTCTime
nextHB UTCTime
now Bool
True (Int -> UTCTime) -> Int -> UTCTime
forall a b. (a -> b) -> a -> b
$ Int
tolerance Int -> Int -> Int
forall a. Num a => a -> a -> a
* Provider -> Int
prvHb Provider
o}
removeR :: Registry -> JobName -> QName -> IO ()
removeR :: Registry -> String -> String -> IO ()
removeR Registry
r String
jn String
qn =
Registry -> (Reg -> IO Reg) -> IO ()
useRegistry_ Registry
r ((Reg -> IO Reg) -> IO ()) -> (Reg -> IO Reg) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Reg
reg -> Reg -> IO Reg
forall (m :: * -> *) a. Monad m => a -> m a
return Reg
reg{regWork :: Map String JobNode
regWork = Map String JobNode -> Map String JobNode
ins (Map String JobNode -> Map String JobNode)
-> Map String JobNode -> Map String JobNode
forall a b. (a -> b) -> a -> b
$ Reg -> Map String JobNode
regWork Reg
reg}
where ins :: Map String JobNode -> Map String JobNode
ins Map String JobNode
m =
case String -> Map String JobNode -> Maybe JobNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
jn Map String JobNode
m of
Maybe JobNode
Nothing -> Map String JobNode
m
Just JobNode
j ->
let ps :: Seq Provider
ps = String -> Seq Provider -> Seq Provider
remProv String
qn (Seq Provider -> Seq Provider) -> Seq Provider -> Seq Provider
forall a b. (a -> b) -> a -> b
$ JobNode -> Seq Provider
jobProvs JobNode
j
in if Seq Provider -> Bool
forall a. Seq a -> Bool
S.null Seq Provider
ps then String -> Map String JobNode -> Map String JobNode
forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
jn Map String JobNode
m
else String -> JobNode -> Map String JobNode -> Map String JobNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
jn JobNode
j{jobProvs :: Seq Provider
jobProvs = Seq Provider
ps} Map String JobNode
m
mapR :: Registry -> JobName -> (Provider -> IO ()) -> IO Bool
mapR :: Registry -> String -> (Provider -> IO ()) -> IO Bool
mapR Registry
r String
jn Provider -> IO ()
f =
Registry -> (Reg -> IO (Reg, Bool)) -> IO Bool
forall r. Registry -> (Reg -> IO (Reg, r)) -> IO r
useRegistry Registry
r ((Reg -> IO (Reg, Bool)) -> IO Bool)
-> (Reg -> IO (Reg, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Reg
reg -> IO UTCTime
getCurrentTime IO UTCTime -> (UTCTime -> IO (Reg, Bool)) -> IO (Reg, Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UTCTime
now ->
UTCTime -> Map String JobNode -> IO (Map String JobNode, Bool)
ins UTCTime
now (Reg -> Map String JobNode
regWork Reg
reg) IO (Map String JobNode, Bool)
-> ((Map String JobNode, Bool) -> IO (Reg, Bool)) -> IO (Reg, Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Map String JobNode
js,Bool
t) ->
(Reg, Bool) -> IO (Reg, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg{regWork :: Map String JobNode
regWork = Map String JobNode
js},Bool
t)
where ins :: UTCTime -> Map String JobNode -> IO (Map String JobNode, Bool)
ins UTCTime
now Map String JobNode
m =
case String -> Map String JobNode -> Maybe JobNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
jn Map String JobNode
m of
Maybe JobNode
Nothing -> (Map String JobNode, Bool) -> IO (Map String JobNode, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map String JobNode
m, Bool
False)
Just JobNode
j ->
let ([Provider]
xs, Seq Provider
ps) = if JobNode -> JobType
jobType JobNode
j JobType -> [JobType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [JobType
Service, JobType
Task]
then UTCTime -> Seq Provider -> ([Provider], Seq Provider)
getHeads UTCTime
now (Seq Provider -> ([Provider], Seq Provider))
-> Seq Provider -> ([Provider], Seq Provider)
forall a b. (a -> b) -> a -> b
$ JobNode -> Seq Provider
jobProvs JobNode
j
else (Seq Provider -> [Provider]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Provider -> [Provider]) -> Seq Provider -> [Provider]
forall a b. (a -> b) -> a -> b
$ JobNode -> Seq Provider
jobProvs JobNode
j,
JobNode -> Seq Provider
jobProvs JobNode
j)
in (Provider -> IO ()) -> [Provider] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Provider -> IO ()
f [Provider]
xs IO ()
-> IO (Map String JobNode, Bool) -> IO (Map String JobNode, Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
(Map String JobNode, Bool) -> IO (Map String JobNode, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> JobNode -> Map String JobNode -> Map String JobNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
jn JobNode
j{jobProvs :: Seq Provider
jobProvs = Seq Provider
ps} Map String JobNode
m, Bool
True)
mapAllR :: Registry -> JobName -> (Provider -> Provider) -> IO ()
mapAllR :: Registry -> String -> (Provider -> Provider) -> IO ()
mapAllR Registry
r String
jn Provider -> Provider
f =
Registry -> (Reg -> IO Reg) -> IO ()
useRegistry_ Registry
r ((Reg -> IO Reg) -> IO ()) -> (Reg -> IO Reg) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Reg
reg -> Map String JobNode -> IO (Map String JobNode)
forall (m :: * -> *).
Monad m =>
Map String JobNode -> m (Map String JobNode)
ins (Reg -> Map String JobNode
regWork Reg
reg) IO (Map String JobNode) -> (Map String JobNode -> IO Reg) -> IO Reg
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Map String JobNode
m ->
Reg -> IO Reg
forall (m :: * -> *) a. Monad m => a -> m a
return Reg
reg{regWork :: Map String JobNode
regWork = Map String JobNode
m}
where ins :: Map String JobNode -> m (Map String JobNode)
ins Map String JobNode
m =
case String -> Map String JobNode -> Maybe JobNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
jn Map String JobNode
m of
Maybe JobNode
Nothing -> Map String JobNode -> m (Map String JobNode)
forall (m :: * -> *) a. Monad m => a -> m a
return Map String JobNode
m
Just JobNode
j -> Map String JobNode -> m (Map String JobNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> JobNode -> Map String JobNode -> Map String JobNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
jn JobNode
j{jobProvs :: Seq Provider
jobProvs = Seq Provider -> Seq Provider
go (Seq Provider -> Seq Provider) -> Seq Provider -> Seq Provider
forall a b. (a -> b) -> a -> b
$ JobNode -> Seq Provider
jobProvs JobNode
j} Map String JobNode
m)
go :: Seq Provider -> Seq Provider
go Seq Provider
s = case Seq Provider -> ViewL Provider
forall a. Seq a -> ViewL a
S.viewl Seq Provider
s of
ViewL Provider
S.EmptyL -> Seq Provider
forall a. Seq a
S.empty
Provider
x :< Seq Provider
ss -> Provider -> Provider
f Provider
x Provider -> Seq Provider -> Seq Provider
forall a. a -> Seq a -> Seq a
<| Seq Provider -> Seq Provider
go Seq Provider
ss
getProvider :: Registry -> JobName -> Int -> IO [Provider]
getProvider :: Registry -> String -> Int -> IO [Provider]
getProvider Registry
r String
jn Int
n =
Registry -> (Reg -> IO (Reg, [Provider])) -> IO [Provider]
forall r. Registry -> (Reg -> IO (Reg, r)) -> IO r
useRegistry Registry
r ((Reg -> IO (Reg, [Provider])) -> IO [Provider])
-> (Reg -> IO (Reg, [Provider])) -> IO [Provider]
forall a b. (a -> b) -> a -> b
$ \Reg
reg -> do UTCTime
now <- IO UTCTime
getCurrentTime
let ([Provider]
x,Map String JobNode
m) = UTCTime -> Map String JobNode -> ([Provider], Map String JobNode)
ins UTCTime
now (Map String JobNode -> ([Provider], Map String JobNode))
-> Map String JobNode -> ([Provider], Map String JobNode)
forall a b. (a -> b) -> a -> b
$ Reg -> Map String JobNode
regWork Reg
reg
(Reg, [Provider]) -> IO (Reg, [Provider])
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg{regWork :: Map String JobNode
regWork = Map String JobNode
m}, [Provider]
x)
where ins :: UTCTime -> Map String JobNode -> ([Provider], Map String JobNode)
ins UTCTime
now Map String JobNode
m = case String -> Map String JobNode -> Maybe JobNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
jn Map String JobNode
m of
Maybe JobNode
Nothing -> ([], Map String JobNode
m)
Just JobNode
j ->
let ([Provider]
x,Seq Provider
ps) = UTCTime -> Seq Provider -> Int -> ([Provider], Seq Provider)
forall a.
(Ord a, Num a) =>
UTCTime -> Seq Provider -> a -> ([Provider], Seq Provider)
go UTCTime
now (JobNode -> Seq Provider
jobProvs JobNode
j) Int
n
in ([Provider]
x, String -> JobNode -> Map String JobNode -> Map String JobNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
jn JobNode
j{jobProvs :: Seq Provider
jobProvs = Seq Provider
ps} Map String JobNode
m)
go :: UTCTime -> Seq Provider -> a -> ([Provider], Seq Provider)
go UTCTime
now Seq Provider
ps a
i | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0 = ([],Seq Provider
ps)
| Bool
otherwise = let (![Provider]
x ,Seq Provider
ps1) = UTCTime -> Seq Provider -> ([Provider], Seq Provider)
getHeads UTCTime
now Seq Provider
ps
(![Provider]
x',Seq Provider
ps2) = UTCTime -> Seq Provider -> a -> ([Provider], Seq Provider)
go UTCTime
now Seq Provider
ps1 (a
ia -> a -> a
forall a. Num a => a -> a -> a
-a
1)
in ([Provider] -> [Provider]
forall a. Eq a => [a] -> [a]
nub ([Provider]
x[Provider] -> [Provider] -> [Provider]
forall a. [a] -> [a] -> [a]
++[Provider]
x'), Seq Provider
ps2)
showRegistry :: Registry -> IO ()
showRegistry :: Registry -> IO ()
showRegistry Registry
r =
Registry -> (Reg -> IO Reg) -> IO ()
useRegistry_ Registry
r ((Reg -> IO Reg) -> IO ()) -> (Reg -> IO Reg) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Reg
reg -> let l :: [String]
l = ((String, JobNode) -> String) -> [(String, JobNode)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, JobNode) -> String
forall a b. (a, b) -> a
fst ([(String, JobNode)] -> [String])
-> [(String, JobNode)] -> [String]
forall a b. (a -> b) -> a -> b
$ Map String JobNode -> [(String, JobNode)]
forall k a. Map k a -> [(k, a)]
M.toList (Reg -> Map String JobNode
regWork Reg
reg)
p :: [[Provider]]
p = (String -> [Provider]) -> [String] -> [[Provider]]
forall a b. (a -> b) -> [a] -> [b]
map (Reg -> String -> [Provider]
getProvs Reg
reg) [String]
l
lp :: [(String, [Provider])]
lp = [String] -> [[Provider]] -> [(String, [Provider])]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
l [[Provider]]
p
in [(String, [Provider])] -> IO ()
forall a. Show a => a -> IO ()
print [(String, [Provider])]
lp IO () -> IO Reg -> IO Reg
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Reg -> IO Reg
forall (m :: * -> *) a. Monad m => a -> m a
return Reg
reg
where getProvs :: Reg -> String -> [Provider]
getProvs Reg
reg String
jn = case String -> Map String JobNode -> Maybe JobNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
jn (Map String JobNode -> Maybe JobNode)
-> Map String JobNode -> Maybe JobNode
forall a b. (a -> b) -> a -> b
$ Reg -> Map String JobNode
regWork Reg
reg of
Maybe JobNode
Nothing -> []
Just JobNode
ps -> Seq Provider -> [Provider]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Provider -> [Provider]) -> Seq Provider -> [Provider]
forall a b. (a -> b) -> a -> b
$ JobNode -> Seq Provider
jobProvs JobNode
ps
withRegistry :: Con -> String -> QName -> (Int, Int)
-> OnError -> (Registry -> IO r) -> IO r
withRegistry :: Con
-> String
-> String
-> (Int, Int)
-> OnError
-> (Registry -> IO r)
-> IO r
withRegistry Con
c String
n String
rq (Int
mn, Int
mx) OnError
onErr Registry -> IO r
action =
Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> InBound ()
-> (Reader () -> IO r)
-> IO r
forall i r.
Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> InBound i
-> (Reader i -> IO r)
-> IO r
withReader Con
c (String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Reader") String
rq [] [] InBound ()
ignorebody ((Reader () -> IO r) -> IO r) -> (Reader () -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Reader ()
r -> do
let nm :: String
nm = String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Registry"
Registry
reg <- MVar Reg -> Registry
Registry (MVar Reg -> Registry) -> IO (MVar Reg) -> IO Registry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reg -> IO (MVar Reg)
forall a. a -> IO (MVar a)
newMVar (String -> Map String JobNode -> Reg
Reg String
nm Map String JobNode
forall k a. Map k a
M.empty)
IO () -> IO r -> IO r
forall r. IO () -> IO r -> IO r
withThread (Registry -> Reader () -> String -> IO ()
forall m r. Registry -> Reader m -> String -> IO r
startReg Registry
reg Reader ()
r String
nm) (Registry -> IO r
action Registry
reg)
where startReg :: Registry -> Reader m -> String -> IO r
startReg Registry
reg Reader m
r String
nm =
Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> OutBound ()
-> (Writer () -> IO r)
-> IO r
forall o r.
Con
-> String
-> String
-> [Qopt]
-> [(String, String)]
-> OutBound o
-> (Writer o -> IO r)
-> IO r
withWriter Con
c (String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Writer") String
"unknown" [] [] OutBound ()
nobody ((Writer () -> IO r) -> IO r) -> (Writer () -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \Writer ()
w ->
IO () -> IO r
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO r) -> IO () -> IO r
forall a b. (a -> b) -> a -> b
$ IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
catches
(do Message m
m <- Reader m -> IO (Message m)
forall a. Reader a -> IO (Message a)
readQ Reader m
r
String
t <- Message m -> IO String
forall m. Message m -> IO String
getMType Message m
m
case String
t of
String
"register" -> Registry -> Message m -> Writer () -> (Int, Int) -> IO ()
forall m. Registry -> Message m -> Writer () -> (Int, Int) -> IO ()
handleRegister Registry
reg Message m
m Writer ()
w (Int
mn,Int
mx)
String
"unreg" -> Registry -> Message m -> Writer () -> IO ()
forall m. Registry -> Message m -> Writer () -> IO ()
handleUnRegister Registry
reg Message m
m Writer ()
w
String
"hb" -> Registry -> Message m -> IO ()
forall m. Registry -> Message m -> IO ()
handleHeartbeat Registry
reg Message m
m
String
x -> PatternsException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (PatternsException -> IO ()) -> PatternsException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> PatternsException
HeaderX String
"__type__" (String -> PatternsException) -> String -> PatternsException
forall a b. (a -> b) -> a -> b
$
String
"Unknown type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x)
(String -> OnError -> [Handler ()]
ignoreHandler String
nm OnError
onErr)
handleRegister :: Registry -> Message m -> Writer () -> (Int, Int) -> IO ()
handleRegister :: Registry -> Message m -> Writer () -> (Int, Int) -> IO ()
handleRegister Registry
r Message m
m Writer ()
w (Int
mn,Int
mx) = do
(String
j,String
q) <- Message m -> IO (String, String)
forall m. Message m -> IO (String, String)
getJobQueue Message m
m
String
ch <- Message m -> IO String
forall m. Message m -> IO String
getChannel Message m
m
JobType
t <- Message m -> IO JobType
forall m. Message m -> IO JobType
getJobType Message m
m
Int
hb <- Message m -> IO Int
forall m. Message m -> IO Int
getHB Message m
m
let h :: Int
h | Int
hb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mn Bool -> Bool -> Bool
|| Int
hb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
mx = if (Int
mn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
hb) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int
hb Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
mx) then Int
mn else Int
mx
| Bool
otherwise = Int
hb
Registry -> String -> JobType -> String -> Int -> IO ()
insertR Registry
r String
j JobType
t String
q Int
h
let hs :: [(String, String)]
hs = [(String
"__sc__", StatusCode -> String
forall a. Show a => a -> String
show StatusCode
OK),
(String
"__hb__", Int -> String
forall a. Show a => a -> String
show Int
h)]
Writer () -> String -> Type -> [(String, String)] -> () -> IO ()
forall a.
Writer a -> String -> Type -> [(String, String)] -> a -> IO ()
writeAdHoc Writer ()
w String
ch Type
nullType [(String, String)]
hs ()
handleUnRegister :: Registry -> Message m -> Writer () -> IO ()
handleUnRegister :: Registry -> Message m -> Writer () -> IO ()
handleUnRegister Registry
r Message m
m Writer ()
w = do
(String
j,String
q) <- Message m -> IO (String, String)
forall m. Message m -> IO (String, String)
getJobQueue Message m
m
String
ch <- Message m -> IO String
forall m. Message m -> IO String
getChannel Message m
m
Registry -> String -> String -> IO ()
removeR Registry
r String
j String
q
let hs :: [(String, String)]
hs=[(String
"__sc__", StatusCode -> String
forall a. Show a => a -> String
show StatusCode
OK)]
Writer () -> String -> Type -> [(String, String)] -> () -> IO ()
forall a.
Writer a -> String -> Type -> [(String, String)] -> a -> IO ()
writeAdHoc Writer ()
w String
ch Type
nullType [(String, String)]
hs ()
handleHeartbeat :: Registry -> Message m -> IO ()
handleHeartbeat :: Registry -> Message m -> IO ()
handleHeartbeat Registry
r Message m
m = do
(String
j,String
q) <- Message m -> IO (String, String)
forall m. Message m -> IO (String, String)
getJobQueue Message m
m
Registry -> String -> String -> IO ()
updR Registry
r String
j String
q
getJobQueue :: Message m -> IO (String, String)
getJobQueue :: Message m -> IO (String, String)
getJobQueue Message m
m = Message m -> IO String
forall m. Message m -> IO String
getJobName Message m
m IO String -> (String -> IO (String, String)) -> IO (String, String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
j -> Message m -> IO String
forall m. Message m -> IO String
getQueue Message m
m IO String -> (String -> IO (String, String)) -> IO (String, String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
q -> (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
j,String
q)
getMType :: Message m -> IO String
getMType :: Message m -> IO String
getMType = String -> String -> Message m -> IO String
forall m. String -> String -> Message m -> IO String
getHeader String
"__type__" String
"No message type in headers"
getJobName :: Message m -> IO String
getJobName :: Message m -> IO String
getJobName = String -> String -> Message m -> IO String
forall m. String -> String -> Message m -> IO String
getHeader String
"__job__" String
"No job name in headers"
getChannel :: Message m -> IO String
getChannel :: Message m -> IO String
getChannel = String -> String -> Message m -> IO String
forall m. String -> String -> Message m -> IO String
getHeader String
"__channel__" String
"No response q in headers"
getQueue :: Message m -> IO String
getQueue :: Message m -> IO String
getQueue = String -> String -> Message m -> IO String
forall m. String -> String -> Message m -> IO String
getHeader String
"__queue__" String
"No queue q in headers"
getJobType :: Message m -> IO JobType
getJobType :: Message m -> IO JobType
getJobType Message m
m =
String -> String -> Message m -> IO String
forall m. String -> String -> Message m -> IO String
getHeader String
"__job-type__" String
"No job type in headers" Message m
m IO String -> (String -> IO JobType) -> IO JobType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
x ->
case String -> Maybe JobType
readJobType String
x of
Maybe JobType
Nothing -> PatternsException -> IO JobType
forall e a. Exception e => e -> IO a
throwIO (PatternsException -> IO JobType)
-> PatternsException -> IO JobType
forall a b. (a -> b) -> a -> b
$ String -> String -> PatternsException
HeaderX String
"__job-type__" (String -> PatternsException) -> String -> PatternsException
forall a b. (a -> b) -> a -> b
$
String
"unknown type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x
Just JobType
t -> JobType -> IO JobType
forall (m :: * -> *) a. Monad m => a -> m a
return JobType
t
getHB :: Message m -> IO Int
getHB :: Message m -> IO Int
getHB Message m
m =
case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"__hb__" ([(String, String)] -> Maybe String)
-> [(String, String)] -> Maybe String
forall a b. (a -> b) -> a -> b
$ Message m -> [(String, String)]
forall a. Message a -> [(String, String)]
msgHdrs Message m
m of
Maybe String
Nothing -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
Just String
v -> if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
v
then Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
v
else PatternsException -> IO Int
forall e a. Exception e => e -> IO a
throwIO (PatternsException -> IO Int) -> PatternsException -> IO Int
forall a b. (a -> b) -> a -> b
$ String -> String -> PatternsException
HeaderX String
"__hb__" (String -> PatternsException) -> String -> PatternsException
forall a b. (a -> b) -> a -> b
$
String
"heartbeat not numeric: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
v
getSC :: Message m -> IO (Either String StatusCode)
getSC :: Message m -> IO (Either String StatusCode)
getSC Message m
m = String -> Either String StatusCode
readStatusCode (String -> Either String StatusCode)
-> IO String -> IO (Either String StatusCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> Message m -> IO String
forall m. String -> String -> Message m -> IO String
getHeader String
"__sc__"
String
"No status code in message" Message m
m
getHeader :: String -> String -> Message m -> IO String
String
h String
e Message m
m = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
h ([(String, String)] -> Maybe String)
-> [(String, String)] -> Maybe String
forall a b. (a -> b) -> a -> b
$ Message m -> [(String, String)]
forall a. Message a -> [(String, String)]
msgHdrs Message m
m of
Maybe String
Nothing -> PatternsException -> IO String
forall e a. Exception e => e -> IO a
throwIO (PatternsException -> IO String) -> PatternsException -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> PatternsException
HeaderX String
h String
e
Just String
v -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
v