0 | module IotaTime.Tzdb.Provider
  1 |
  2 | import IotaTime.TimeZone.Core
  3 | import IotaTime.TimeZone.Error
  4 | import IotaTime.Tzdb.Metadata
  5 | import Data.IORef
  6 | import Data.List
  7 | import System.Concurrency
  8 |
  9 | %default total
 10 |
 11 | ||| Platform-specific time-zone discovery behind one shared contract.
 12 | export
 13 | record TimeZoneProviderRep where
 14 |   constructor MkTimeZoneProvider
 15 |   providerUtc : IO (Either TzdbError TimeZone)
 16 |   providerTimeZone : String -> IO (Either TzdbError TimeZone)
 17 |   providerLocalZone : IO (Either TzdbError TimeZone)
 18 |   providerAvailableZones : IO (Either TzdbError (List String))
 19 |   providerMetadata : IO (Either TzdbError TzdbMetadata)
 20 |
 21 | export
 22 | timeZoneProvider : IO (Either TzdbError TimeZone) ->
 23 |                    (String -> IO (Either TzdbError TimeZone)) ->
 24 |                    IO (Either TzdbError TimeZone) ->
 25 |                    IO (Either TzdbError (List String)) ->
 26 |                    IO (Either TzdbError TzdbMetadata) ->
 27 |                    TimeZoneProviderRep
 28 | timeZoneProvider = MkTimeZoneProvider
 29 |
 30 | export
 31 | runProviderUtc : TimeZoneProviderRep -> IO (Either TzdbError TimeZone)
 32 | runProviderUtc (MkTimeZoneProvider action _ _ _ _) = action
 33 |
 34 | export
 35 | runProviderTimeZone : TimeZoneProviderRep -> String ->
 36 |                       IO (Either TzdbError TimeZone)
 37 | runProviderTimeZone (MkTimeZoneProvider _ action _ _ _) = action
 38 |
 39 | export
 40 | runProviderLocalZone : TimeZoneProviderRep -> IO (Either TzdbError TimeZone)
 41 | runProviderLocalZone (MkTimeZoneProvider _ _ action _ _) = action
 42 |
 43 | export
 44 | runProviderAvailableZones : TimeZoneProviderRep ->
 45 |                             IO (Either TzdbError (List String))
 46 | runProviderAvailableZones (MkTimeZoneProvider _ _ _ action _) = action
 47 |
 48 | export
 49 | runProviderMetadata : TimeZoneProviderRep -> IO (Either TzdbError TzdbMetadata)
 50 | runProviderMetadata (MkTimeZoneProvider _ _ _ _ action) = action
 51 |
 52 | ||| Selects which successful provider queries are retained in memory.
 53 | ||| Failures are always retried. Local-zone caching is independent because the
 54 | ||| host's local-zone configuration may change while a process is running.
 55 | export
 56 | record TimeZoneCachePolicyRep where
 57 |   constructor MkTimeZoneCachePolicy
 58 |   cacheNamedZones : Bool
 59 |   cacheAvailableZones : Bool
 60 |   cacheMetadata : Bool
 61 |   cacheLocalZone : Bool
 62 |
 63 | export
 64 | timeZoneCachePolicy : (cacheNamedZones : Bool) ->
 65 |                       (cacheAvailableZones : Bool) ->
 66 |                       (cacheMetadata : Bool) ->
 67 |                       (cacheLocalZone : Bool) ->
 68 |                       TimeZoneCachePolicyRep
 69 | timeZoneCachePolicy = MkTimeZoneCachePolicy
 70 |
 71 | ||| Cache named zones, discovery, and metadata while continuing to observe
 72 | ||| changes to the host's local-zone configuration.
 73 | export
 74 | defaultTimeZoneCachePolicy : TimeZoneCachePolicyRep
 75 | defaultTimeZoneCachePolicy = MkTimeZoneCachePolicy True True True False
 76 |
 77 | withMutex : Mutex -> IO value -> IO value
 78 | withMutex mutex action = do
 79 |   mutexAcquire mutex
 80 |   result <- action
 81 |   mutexRelease mutex
 82 |   pure result
 83 |
 84 | cachedSuccessful : Bool -> Mutex -> IORef (Maybe value) ->
 85 |                    IO (Either error value) -> IO (Either error value)
 86 | cachedSuccessful False mutex reference load = load
 87 | cachedSuccessful True mutex reference load = withMutex mutex $ do
 88 |   cached <- readIORef reference
 89 |   case cached of
 90 |     Just value => pure (Right value)
 91 |     Nothing => do
 92 |       loaded <- load
 93 |       case loaded of
 94 |         Left error => pure (Left error)
 95 |         Right value => do
 96 |           writeIORef reference (Just value)
 97 |           pure (Right value)
 98 |
 99 | cachedNamedZone : Bool -> Mutex -> IORef (List (String, TimeZone)) ->
100 |                   (String -> IO (Either TzdbError TimeZone)) -> String ->
101 |                   IO (Either TzdbError TimeZone)
102 | cachedNamedZone False mutex reference load name = load name
103 | cachedNamedZone True mutex reference load name = withMutex mutex $ do
104 |   cached <- readIORef reference
105 |   case lookup name cached of
106 |     Just zone => pure (Right zone)
107 |     Nothing => do
108 |       loaded <- load name
109 |       case loaded of
110 |         Left error => pure (Left error)
111 |         Right zone => do
112 |           writeIORef reference ((name, zone) :: cached)
113 |           pure (Right zone)
114 |
115 | ||| Wrap a provider in caller-owned, opt-in successful-result caches.
116 | ||| Construct a new wrapper to refresh all cached values.
117 | export
118 | cachedTimeZoneProvider : TimeZoneCachePolicyRep -> TimeZoneProviderRep ->
119 |                          IO TimeZoneProviderRep
120 | cachedTimeZoneProvider policy provider = do
121 |   namedLock <- makeMutex
122 |   availableLock <- makeMutex
123 |   metadataLock <- makeMutex
124 |   localLock <- makeMutex
125 |   namedCache <- newIORef []
126 |   availableCache <- newIORef Nothing
127 |   metadataCache <- newIORef Nothing
128 |   localCache <- newIORef Nothing
129 |   pure $ MkTimeZoneProvider
130 |     provider.providerUtc
131 |     (cachedNamedZone policy.cacheNamedZones namedLock namedCache
132 |       provider.providerTimeZone)
133 |     (cachedSuccessful policy.cacheLocalZone localLock localCache
134 |       provider.providerLocalZone)
135 |     (cachedSuccessful policy.cacheAvailableZones availableLock availableCache
136 |       provider.providerAvailableZones)
137 |     (cachedSuccessful policy.cacheMetadata metadataLock metadataCache
138 |       provider.providerMetadata)
139 |