concurrent-dns-cache 0.0.1 → 0.1.0

raw patch · 6 files changed

+41/−522 lines, 6 filesdep +lifted-basedep +monad-controldep +psqueuesdep −hashablePVP ok

version bump matches the API change (PVP)

Dependencies added: lifted-base, monad-control, psqueues, transformers

Dependencies removed: hashable

API changes (from Hackage documentation)

Files

• Network/DNS/Cache.hs +15/−10
• Network/DNS/Cache/Cache.hs +5/−14
• Network/DNS/Cache/PSQ.hs +0/−480
• Network/DNS/Cache/Types.hs +2/−12
• concurrent-dns-cache.cabal +13/−4
• test/CacheSpec.hs +6/−2

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}  -- | DNS cache to resolve domains concurrently.@@ -19,11 +20,14 @@   ) where  import Control.Applicative ((<$>))-import Control.Concurrent (threadDelay, forkIO, killThread)+import Control.Concurrent.Lifted (threadDelay, fork, killThread) import Control.Concurrent.Async (async, waitAnyCancel)-import Control.Exception (bracket)-import Control.Monad (forever, void)+import Control.Exception.Lifted (bracket)+import Control.Monad (forever)+import Control.Monad.IO.Class+import Control.Monad.Trans.Control import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Short as B import Data.IP (toHostAddress) import Data.Time (getCurrentTime, addUTCTime, NominalDiffTime) import Network.DNS hiding (lookup)@@ -70,15 +74,16 @@  -- | A basic function to create DNS cache. --   Domains should be resolved in the function of the second argument.-withDNSCache :: DNSCacheConf -> (DNSCache -> IO a) -> IO a+withDNSCache :: (MonadBaseControl IO m, MonadIO m)+             => DNSCacheConf -> (DNSCache -> m a) -> m a withDNSCache conf func = do-    seeds <- mapM makeResolvSeed (resolvConfs conf)+    seeds <- mapM (liftIO . makeResolvSeed) (resolvConfs conf)     let n = length seeds-    cacheref <- newCacheRef-    activeref <- S.newActiveRef-    lvar <- S.newConcVar+    cacheref <- liftIO newCacheRef+    activeref <- liftIO S.newActiveRef+    lvar <- liftIO S.newConcVar     let cache = DNSCache seeds n cacheref activeref lvar maxcon minttl maxttl negttl-    bracket (forkIO $ prune cacheref) killThread (const $ func cache)+    bracket (fork $ liftIO $ prune cacheref) killThread (const $ func cache)   where     maxcon = maxConcurrency conf     minttl = minTTL conf@@ -93,7 +98,7 @@     return (key,mx)   where     cacheref = cacheRef cache-    !key = newKey dom+    !key = B.toShort dom  ---------------------------------------------------------------- 

@@ -6,19 +6,16 @@   , lookupCacheRef   , insertCacheRef   , pruneCacheRef-  , newKey   ) where  import Control.Applicative ((<$>))-import Data.ByteString (ByteString)-import qualified Data.ByteString.Short as B-import Data.Hashable (hash) import Data.IORef (newIORef, readIORef, atomicModifyIORef', IORef)-import Network.DNS.Cache.PSQ (PSQ)-import qualified Network.DNS.Cache.PSQ as PSQ+import Data.OrdPSQ (OrdPSQ)+import qualified Data.OrdPSQ as PSQ import Network.DNS.Cache.Types -newtype CacheRef = CacheRef (IORef (PSQ Entry))+type PSQ = OrdPSQ+newtype CacheRef = CacheRef (IORef (PSQ Key Prio Entry))  newCacheRef :: IO CacheRef newCacheRef = CacheRef <$> newIORef PSQ.empty@@ -32,10 +29,4 @@  pruneCacheRef :: Prio -> CacheRef -> IO () pruneCacheRef tim (CacheRef ref) =-    atomicModifyIORef' ref $ \p -> (snd (PSQ.atMost tim p), ())--newKey :: ByteString -> Key-newKey dom = Key h k-  where-    !k = B.toShort dom-    !h = hash dom+    atomicModifyIORef' ref $ \p -> (snd (PSQ.atMostView tim p), ())

@@ -1,480 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- From ghc-7.6.3/libraries/base/GHC/Event/PSQ.hs---- Copyright (c) 2008, Ralf Hinze--- 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.------     * The names of the contributors may not 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 OWNER 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.---- | A /priority search queue/ (henceforth /queue/) efficiently--- supports the operations of both a search tree and a priority queue.--- An 'Elem'ent is a product of a key, a priority, and a--- value. Elements can be inserted, deleted, modified and queried in--- logarithmic time, and the element with the least priority can be--- retrieved in constant time.  A queue can be built from a list of--- elements, sorted by keys, in linear time.------ This implementation is due to Ralf Hinze with some modifications by--- Scott Dillard and Johan Tibell.------ * Hinze, R., /A Simple Implementation Technique for Priority Search--- Queues/, ICFP 2001, pp. 110-121------ <http://citeseer.ist.psu.edu/hinze01simple.html>-module Network.DNS.Cache.PSQ-    (-    -- * Binding Type-    Elem(..)-    , Key-    , Prio--    -- * Priority Search Queue Type-    , PSQ--    -- * Query-    , size-    , null-    , lookup--    -- * Construction-    , empty-    , singleton--    -- * Insertion-    , insert--    -- * Delete/Update-    , delete-    , adjust--    -- * Conversion-    , toList-    , toAscList-    , toDescList-    , fromList--    -- * Min-    , findMin-    , deleteMin-    , minView-    , atMost-    ) where--import Network.DNS.Cache.Types-import Prelude hiding (lookup, null)---- | @E k p@ binds the key @k@ with the priority @p@.-data Elem a = E-    { key   :: {-# UNPACK #-} !Key-    , prio  :: {-# UNPACK #-} !Prio-    , value :: a-    } deriving (Eq, Show)----------------------------------------------------------------------------- | A mapping from keys @k@ to priorites @p@.--data PSQ a = Void-           | Winner {-# UNPACK #-} !(Elem a)-                    !(LTree a)-                    {-# UNPACK #-} !Key  -- max key-           deriving (Eq, Show)---- | /O(1)/ The number of elements in a queue.-size :: PSQ a -> Int-size Void            = 0-size (Winner _ lt _) = 1 + size' lt---- | /O(1)/ True if the queue is empty.-null :: PSQ a -> Bool-null Void           = True-null (Winner _ _ _) = False---- | /O(log n)/ The priority and value of a given key, or Nothing if--- the key is not bound.-lookup :: Key -> PSQ a -> Maybe (Prio, a)-lookup k q = case tourView q of-    Null -> Nothing-    Single (E k' p v)-        | k == k'   -> Just (p, v)-        | otherwise -> Nothing-    tl `Play` tr-        | k <= maxKey tl -> lookup k tl-        | otherwise      -> lookup k tr----------------------------------------------------------------------------- Construction--empty :: PSQ a-empty = Void---- | /O(1)/ Build a queue with one element.-singleton :: Key -> Prio -> a -> PSQ a-singleton k p v = Winner (E k p v) Start k----------------------------------------------------------------------------- Insertion---- | /O(log n)/ Insert a new key, priority and value in the queue.  If--- the key is already present in the queue, the associated priority--- and value are replaced with the supplied priority and value.-insert :: Key -> Prio -> a -> PSQ a -> PSQ a-insert k p v q = case q of-    Void -> singleton k p v-    Winner (E k' p' v') Start _ -> case compare k k' of-        LT -> singleton k  p  v  `play` singleton k' p' v'-        EQ -> singleton k  p  v-        GT -> singleton k' p' v' `play` singleton k  p  v-    Winner e (RLoser _ e' tl m tr) m'-        | k <= m    -> insert k p v (Winner e tl m) `play` (Winner e' tr m')-        | otherwise -> (Winner e tl m) `play` insert k p v (Winner e' tr m')-    Winner e (LLoser _ e' tl m tr) m'-        | k <= m    -> insert k p v (Winner e' tl m) `play` (Winner e tr m')-        | otherwise -> (Winner e' tl m) `play` insert k p v (Winner e tr m')----------------------------------------------------------------------------- Delete/Update---- | /O(log n)/ Delete a key and its priority and value from the--- queue.  When the key is not a member of the queue, the original--- queue is returned.-delete :: Key -> PSQ a -> PSQ a-delete k q = case q of-    Void -> empty-    Winner (E k' p v) Start _-        | k == k'   -> empty-        | otherwise -> singleton k' p v-    Winner e (RLoser _ e' tl m tr) m'-        | k <= m    -> delete k (Winner e tl m) `play` (Winner e' tr m')-        | otherwise -> (Winner e tl m) `play` delete k (Winner e' tr m')-    Winner e (LLoser _ e' tl m tr) m'-        | k <= m    -> delete k (Winner e' tl m) `play` (Winner e tr m')-        | otherwise -> (Winner e' tl m) `play` delete k (Winner e tr m')---- | /O(log n)/ Update a priority at a specific key with the result--- of the provided function.  When the key is not a member of the--- queue, the original queue is returned.-adjust :: (Prio -> Prio) -> Key -> PSQ a -> PSQ a-adjust f k q0 =  go q0-  where-    go q = case q of-        Void -> empty-        Winner (E k' p v) Start _-            | k == k'   -> singleton k' (f p) v-            | otherwise -> singleton k' p v-        Winner e (RLoser _ e' tl m tr) m'-            | k <= m    -> go (Winner e tl m) `unsafePlay` (Winner e' tr m')-            | otherwise -> (Winner e tl m) `unsafePlay` go (Winner e' tr m')-        Winner e (LLoser _ e' tl m tr) m'-            | k <= m    -> go (Winner e' tl m) `unsafePlay` (Winner e tr m')-            | otherwise -> (Winner e' tl m) `unsafePlay` go (Winner e tr m')-{-# INLINE adjust #-}----------------------------------------------------------------------------- Conversion---- | /O(n*log n)/ Build a queue from a list of key/priority/value--- tuples.  If the list contains more than one priority and value for--- the same key, the last priority and value for the key is retained.-fromList :: [Elem a] -> PSQ a-fromList = foldr (\(E k p v) q -> insert k p v q) empty---- | /O(n)/ Convert to a list of key/priority/value tuples.-toList :: PSQ a -> [Elem a]-toList = toAscList---- | /O(n)/ Convert to an ascending list.-toAscList :: PSQ a -> [Elem a]-toAscList q  = seqToList (toAscLists q)--toAscLists :: PSQ a -> Sequ (Elem a)-toAscLists q = case tourView q of-    Null         -> emptySequ-    Single e     -> singleSequ e-    tl `Play` tr -> toAscLists tl <> toAscLists tr---- | /O(n)/ Convert to a descending list.-toDescList :: PSQ a -> [ Elem a ]-toDescList q = seqToList (toDescLists q)--toDescLists :: PSQ a -> Sequ (Elem a)-toDescLists q = case tourView q of-    Null         -> emptySequ-    Single e     -> singleSequ e-    tl `Play` tr -> toDescLists tr <> toDescLists tl----------------------------------------------------------------------------- Min---- | /O(1)/ The element with the lowest priority.-findMin :: PSQ a -> Maybe (Elem a)-findMin Void           = Nothing-findMin (Winner e _ _) = Just e---- | /O(log n)/ Delete the element with the lowest priority.  Returns--- an empty queue if the queue is empty.-deleteMin :: PSQ a -> PSQ a-deleteMin Void           = Void-deleteMin (Winner _ t m) = secondBest t m---- | /O(log n)/ Retrieve the binding with the least priority, and the--- rest of the queue stripped of that binding.-minView :: PSQ a -> Maybe (Elem a, PSQ a)-minView Void           = Nothing-minView (Winner e t m) = Just (e, secondBest t m)--secondBest :: LTree a -> Key -> PSQ a-secondBest Start _                 = Void-secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m'-secondBest (RLoser _ e tl m tr) m' = secondBest tl m `play` Winner e tr m'---- | /O(r*(log n - log r))/ Return a list of elements ordered by--- key whose priorities are at most @pt@.-atMost :: Prio -> PSQ a -> ([Elem a], PSQ a)-atMost pt q = let (sequ, q') = atMosts pt q-              in (seqToList sequ, q')--atMosts :: Prio -> PSQ a -> (Sequ (Elem a), PSQ a)-atMosts !pt q = case q of-    (Winner e _ _)-        | prio e > pt -> (emptySequ, q)-    Void              -> (emptySequ, Void)-    Winner e Start _  -> (singleSequ e, Void)-    Winner e (RLoser _ e' tl m tr) m' ->-        let (sequ, q')   = atMosts pt (Winner e tl m)-            (sequ', q'') = atMosts pt (Winner e' tr m')-        in (sequ <> sequ', q' `play` q'')-    Winner e (LLoser _ e' tl m tr) m' ->-        let (sequ, q')   = atMosts pt (Winner e' tl m)-            (sequ', q'') = atMosts pt (Winner e tr m')-        in (sequ <> sequ', q' `play` q'')----------------------------------------------------------------------------- Loser tree--type Size = Int--data LTree a = Start-             | LLoser {-# UNPACK #-} !Size-                      {-# UNPACK #-} !(Elem a)-                      !(LTree a)-                      {-# UNPACK #-} !Key  -- split key-                      !(LTree a)-             | RLoser {-# UNPACK #-} !Size-                      {-# UNPACK #-} !(Elem a)-                      !(LTree a)-                      {-# UNPACK #-} !Key  -- split key-                      !(LTree a)-             deriving (Eq, Show)--size' :: LTree a -> Size-size' Start              = 0-size' (LLoser s _ _ _ _) = s-size' (RLoser s _ _ _ _) = s--left, right :: LTree a -> LTree a--left Start                = moduleError "left" "empty loser tree"-left (LLoser _ _ tl _ _ ) = tl-left (RLoser _ _ tl _ _ ) = tl--right Start                = moduleError "right" "empty loser tree"-right (LLoser _ _ _  _ tr) = tr-right (RLoser _ _ _  _ tr) = tr--maxKey :: PSQ a -> Key-maxKey Void           = moduleError "maxKey" "empty queue"-maxKey (Winner _ _ m) = m--lloser, rloser :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-lloser k p v tl m tr = LLoser (1 + size' tl + size' tr) (E k p v) tl m tr-rloser k p v tl m tr = RLoser (1 + size' tl + size' tr) (E k p v) tl m tr----------------------------------------------------------------------------- Balancing---- | Balance factor-omega :: Int-omega = 4--lbalance, rbalance :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a--lbalance k p v l m r-    | size' l + size' r < 2     = lloser        k p v l m r-    | size' r > omega * size' l = lbalanceLeft  k p v l m r-    | size' l > omega * size' r = lbalanceRight k p v l m r-    | otherwise                 = lloser        k p v l m r--rbalance k p v l m r-    | size' l + size' r < 2     = rloser        k p v l m r-    | size' r > omega * size' l = rbalanceLeft  k p v l m r-    | size' l > omega * size' r = rbalanceRight k p v l m r-    | otherwise                 = rloser        k p v l m r--lbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-lbalanceLeft  k p v l m r-    | size' (left r) < size' (right r) = lsingleLeft  k p v l m r-    | otherwise                        = ldoubleLeft  k p v l m r--lbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-lbalanceRight k p v l m r-    | size' (left l) > size' (right l) = lsingleRight k p v l m r-    | otherwise                        = ldoubleRight k p v l m r--rbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rbalanceLeft  k p v l m r-    | size' (left r) < size' (right r) = rsingleLeft  k p v l m r-    | otherwise                        = rdoubleLeft  k p v l m r--rbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rbalanceRight k p v l m r-    | size' (left l) > size' (right l) = rsingleRight k p v l m r-    | otherwise                        = rdoubleRight k p v l m r--lsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-lsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3)-    | p1 <= p2  = lloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3-    | otherwise = lloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3-lsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =-    rloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3-lsingleLeft _ _ _ _ _ _ = moduleError "lsingleLeft" "malformed tree"--rsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =-    rloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3-rsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =-    rloser k2 p2 v2 (rloser k1 p1 v1 t1 m1 t2) m2 t3-rsingleLeft _ _ _ _ _ _ = moduleError "rsingleLeft" "malformed tree"--lsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-lsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    lloser k2 p2 v2 t1 m1 (lloser k1 p1 v1 t2 m2 t3)-lsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    lloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3)-lsingleRight _ _ _ _ _ _ = moduleError "lsingleRight" "malformed tree"--rsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    lloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3)-rsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3-    | p1 <= p2  = rloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3)-    | otherwise = rloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3)-rsingleRight _ _ _ _ _ _ = moduleError "rsingleRight" "malformed tree"--ldoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-ldoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =-    lsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3)-ldoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =-    lsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3)-ldoubleLeft _ _ _ _ _ _ = moduleError "ldoubleLeft" "malformed tree"--ldoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-ldoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    lsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3-ldoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    lsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3-ldoubleRight _ _ _ _ _ _ = moduleError "ldoubleRight" "malformed tree"--rdoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rdoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) =-    rsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3)-rdoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) =-    rsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3)-rdoubleLeft _ _ _ _ _ _ = moduleError "rdoubleLeft" "malformed tree"--rdoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a-rdoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    rsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3-rdoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 =-    rsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3-rdoubleRight _ _ _ _ _ _ = moduleError "rdoubleRight" "malformed tree"---- | Take two pennants and returns a new pennant that is the union of--- the two with the precondition that the keys in the first tree are--- strictly smaller than the keys in the second tree.-play :: PSQ a -> PSQ a -> PSQ a-Void `play` t' = t'-t `play` Void  = t-Winner e@(E k p v) t m `play` Winner e'@(E k' p' v') t' m'-    | p <= p'   = Winner e (rbalance k' p' v' t m t') m'-    | otherwise = Winner e' (lbalance k p v t m t') m'-{-# INLINE play #-}---- | A version of 'play' that can be used if the shape of the tree has--- not changed or if the tree is known to be balanced.-unsafePlay :: PSQ a -> PSQ a -> PSQ a-Void `unsafePlay` t' =  t'-t `unsafePlay` Void  =  t-Winner e@(E k p v) t m `unsafePlay` Winner e'@(E k' p' v') t' m'-    | p <= p'   = Winner e (rloser k' p' v' t m t') m'-    | otherwise = Winner e' (lloser k p v t m t') m'-{-# INLINE unsafePlay #-}--data TourView a = Null-                | Single {-# UNPACK #-} !(Elem a)-                | (PSQ a) `Play` (PSQ a)--tourView :: PSQ a -> TourView a-tourView Void               = Null-tourView (Winner e Start _) = Single e-tourView (Winner e (RLoser _ e' tl m tr) m') =-    Winner e tl m `Play` Winner e' tr m'-tourView (Winner e (LLoser _ e' tl m tr) m') =-    Winner e' tl m `Play` Winner e tr m'----------------------------------------------------------------------------- Utility functions--moduleError :: String -> String -> a-moduleError fun msg = error ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg)-{-# NOINLINE moduleError #-}----------------------------------------------------------------------------- Hughes's efficient sequence type--newtype Sequ a = Sequ ([a] -> [a])--emptySequ :: Sequ a-emptySequ = Sequ (\as -> as)--singleSequ :: a -> Sequ a-singleSequ a = Sequ (\as -> a : as)--(<>) :: Sequ a -> Sequ a -> Sequ a-Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as))-infixr 5 <>--seqToList :: Sequ a -> [a]-seqToList (Sequ x) = x []--instance Show a => Show (Sequ a) where-    showsPrec d a = showsPrec d (seqToList a)-

@@ -1,6 +1,5 @@ module Network.DNS.Cache.Types (-    Hash-  , Key(..)+    Key   , Prio   , Value(..)   , Entry@@ -18,16 +17,7 @@ import Network.DNS (Domain, DNSError(..)) import Network.Socket (HostAddress) -type Hash = Int--data Key = Key !Hash            -- making lookup faster-               !ShortByteString -- avoiding memory fragmentation-               deriving (Ord,Show)--instance Eq Key where-    -- Just ensuring the order of evaluation.-    Key h1 k1 == Key h2 k2 = h1 == h2 && k1 == k2-+type Key = ShortByteString -- avoiding memory fragmentation type Prio = UTCTime  -- fixme: if UArray causes memory fragments,

@@ -1,5 +1,5 @@ Name:                   concurrent-dns-cache-Version:                0.0.1+Version:                0.1.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -15,7 +15,6 @@   GHC-Options:          -Wall   Exposed-Modules:      Network.DNS.Cache   Other-Modules:        Network.DNS.Cache.Cache-                        Network.DNS.Cache.PSQ                         Network.DNS.Cache.Sync                         Network.DNS.Cache.Types                         Network.DNS.Cache.Utils@@ -26,11 +25,14 @@                       , bytestring >= 0.10.4.0                       , containers                       , dns-                      , hashable                       , iproute+                      , lifted-base+                      , monad-control                       , network+                      , psqueues >= 0.2.3                       , stm                       , time+                      , transformers  Executable main   Main-Is:              main.hs@@ -42,11 +44,14 @@                       , bytestring >= 0.10.4.0                       , containers                       , dns-                      , hashable                       , iproute+                      , lifted-base+                      , monad-control                       , network+                      , psqueues                       , stm                       , time+                      , transformers  Test-Suite spec   Main-Is:              Spec.hs@@ -59,3 +64,7 @@                       , concurrent-dns-cache                       , dns                       , hspec++Source-Repository head+  Type:                 git+  Location:             https://github.com/kazu-yamamoto/concurrent-dns-cache

@@ -24,7 +24,7 @@ spec = describe "withDnsCache" $ do     it "resolves domains and caches addresses" $ withDNSCache cacheConf $ \cache -> do         let dom = "www.example.com"-            addr = 2010691677+            addr = 584628317         resolve      cache dom `shouldReturn` Right (Resolved addr)         resolveCache cache dom `shouldReturn` Just (Right (Hit addr))         lookupCache  cache dom `shouldReturn` Just addr@@ -45,6 +45,10 @@         lookup       cache dom `shouldReturn` Nothing     it "waits for another query for the same domain" $ withDNSCache cacheConf $ \cache -> do         let dom = "www.example.com"-            addr = 2010691677+            addr = 584628317         (res1,res2) <- concurrently (resolve cache dom) (resolve cache dom)         [res1,res2] `shouldContain` [Right (Resolved addr),Right (Hit addr)]+    it "just returns IP address" $ withDNSCache cacheConf $ \cache -> do+        let dom = "192.0.2.1"+            addr = 16908480+        resolve      cache dom `shouldReturn` Right (Numeric addr)