diff options
Diffstat (limited to 'bittorrent/src/Network/BitTorrent/Internal/Cache.hs')
-rw-r--r-- | bittorrent/src/Network/BitTorrent/Internal/Cache.hs | 169 |
1 files changed, 169 insertions, 0 deletions
diff --git a/bittorrent/src/Network/BitTorrent/Internal/Cache.hs b/bittorrent/src/Network/BitTorrent/Internal/Cache.hs new file mode 100644 index 00000000..8c74467a --- /dev/null +++ b/bittorrent/src/Network/BitTorrent/Internal/Cache.hs | |||
@@ -0,0 +1,169 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2014 | ||
3 | -- License : BSD | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- Cached data for tracker responses. | ||
9 | -- | ||
10 | module Network.BitTorrent.Internal.Cache | ||
11 | ( -- * Cache | ||
12 | Cached | ||
13 | , lastUpdated | ||
14 | , updateInterval | ||
15 | , minUpdateInterval | ||
16 | |||
17 | -- * Construction | ||
18 | , newCached | ||
19 | , newCached_ | ||
20 | |||
21 | -- * Query | ||
22 | , isAlive | ||
23 | , isStalled | ||
24 | , isExpired | ||
25 | , canUpdate | ||
26 | , shouldUpdate | ||
27 | |||
28 | -- * Cached data | ||
29 | , tryTakeData | ||
30 | , unsafeTryTakeData | ||
31 | , takeData | ||
32 | ) where | ||
33 | |||
34 | import Control.Applicative | ||
35 | import Data.Monoid | ||
36 | import Data.Default | ||
37 | import Data.Time | ||
38 | import Data.Time.Clock.POSIX | ||
39 | import System.IO.Unsafe | ||
40 | |||
41 | |||
42 | data Cached a = Cached | ||
43 | { -- | Time of resource creation. | ||
44 | lastUpdated :: !POSIXTime | ||
45 | |||
46 | -- | Minimum invalidation timeout. | ||
47 | , minUpdateInterval :: !NominalDiffTime | ||
48 | |||
49 | -- | Resource lifetime. | ||
50 | , updateInterval :: !NominalDiffTime | ||
51 | |||
52 | -- | Resource data. | ||
53 | , cachedData :: a | ||
54 | } deriving (Show, Eq) | ||
55 | |||
56 | -- INVARIANT: minUpdateInterval <= updateInterval | ||
57 | |||
58 | instance Default (Cached a) where | ||
59 | def = mempty | ||
60 | |||
61 | instance Functor Cached where | ||
62 | fmap f (Cached t i m a) = Cached t i m (f a) | ||
63 | |||
64 | posixEpoch :: NominalDiffTime | ||
65 | posixEpoch = 1000000000000000000000000000000000000000000000000000000 | ||
66 | |||
67 | instance Applicative Cached where | ||
68 | pure = Cached 0 posixEpoch posixEpoch | ||
69 | f <*> c = Cached | ||
70 | { lastUpdated = undefined | ||
71 | , minUpdateInterval = undefined | ||
72 | , updateInterval = undefined | ||
73 | , cachedData = cachedData f (cachedData c) | ||
74 | } | ||
75 | |||
76 | instance Alternative Cached where | ||
77 | empty = mempty | ||
78 | (<|>) = error "cached alternative instance: not implemented" | ||
79 | |||
80 | instance Monad Cached where | ||
81 | return = pure | ||
82 | Cached {..} >>= f = Cached | ||
83 | { lastUpdated = undefined | ||
84 | , updateInterval = undefined | ||
85 | , minUpdateInterval = undefined | ||
86 | , cachedData = undefined | ||
87 | } | ||
88 | |||
89 | instance Monoid (Cached a) where | ||
90 | mempty = Cached | ||
91 | { lastUpdated = 0 | ||
92 | , minUpdateInterval = 0 | ||
93 | , updateInterval = 0 | ||
94 | , cachedData = error "cached mempty: impossible happen" | ||
95 | } | ||
96 | |||
97 | mappend a b | ||
98 | | expirationTime a > expirationTime b = a | ||
99 | | otherwise = b | ||
100 | |||
101 | normalize :: NominalDiffTime -> NominalDiffTime | ||
102 | -> (NominalDiffTime, NominalDiffTime) | ||
103 | normalize a b | ||
104 | | a < b = (a, b) | ||
105 | | otherwise = (b, a) | ||
106 | {-# INLINE normalize #-} | ||
107 | |||
108 | newCached :: NominalDiffTime -> NominalDiffTime -> a -> IO (Cached a) | ||
109 | newCached minInterval interval x = do | ||
110 | t <- getPOSIXTime | ||
111 | let (mui, ui) = normalize minInterval interval | ||
112 | return Cached | ||
113 | { lastUpdated = t | ||
114 | , minUpdateInterval = mui | ||
115 | , updateInterval = ui | ||
116 | , cachedData = x | ||
117 | } | ||
118 | |||
119 | newCached_ :: NominalDiffTime -> a -> IO (Cached a) | ||
120 | newCached_ interval x = newCached interval interval x | ||
121 | {-# INLINE newCached_ #-} | ||
122 | |||
123 | expirationTime :: Cached a -> POSIXTime | ||
124 | expirationTime Cached {..} = undefined | ||
125 | |||
126 | isAlive :: Cached a -> IO Bool | ||
127 | isAlive Cached {..} = do | ||
128 | currentTime <- getPOSIXTime | ||
129 | return $ lastUpdated + updateInterval > currentTime | ||
130 | |||
131 | isExpired :: Cached a -> IO Bool | ||
132 | isExpired Cached {..} = undefined | ||
133 | |||
134 | isStalled :: Cached a -> IO Bool | ||
135 | isStalled Cached {..} = undefined | ||
136 | |||
137 | canUpdate :: Cached a -> IO (Maybe NominalDiffTime) | ||
138 | canUpdate = undefined --isStaled | ||
139 | |||
140 | shouldUpdate :: Cached a -> IO (Maybe NominalDiffTime) | ||
141 | shouldUpdate = undefined -- isExpired | ||
142 | |||
143 | tryTakeData :: Cached a -> IO (Maybe a) | ||
144 | tryTakeData c = do | ||
145 | alive <- isAlive c | ||
146 | return $ if alive then Just (cachedData c) else Nothing | ||
147 | |||
148 | unsafeTryTakeData :: Cached a -> Maybe a | ||
149 | unsafeTryTakeData = unsafePerformIO . tryTakeData | ||
150 | |||
151 | invalidateData :: Cached a -> IO a -> IO (Cached a) | ||
152 | invalidateData Cached {..} action = do | ||
153 | t <- getPOSIXTime | ||
154 | x <- action | ||
155 | return Cached | ||
156 | { lastUpdated = t | ||
157 | , updateInterval = updateInterval | ||
158 | , minUpdateInterval = minUpdateInterval | ||
159 | , cachedData = x | ||
160 | } | ||
161 | |||
162 | takeData :: Cached a -> IO a -> IO a | ||
163 | takeData c action = do | ||
164 | mdata <- tryTakeData c | ||
165 | case mdata of | ||
166 | Just a -> return a | ||
167 | Nothing -> do | ||
168 | c' <- invalidateData c action | ||
169 | takeData c' action | ||