
   0 | module IotaTime.Tzdb.Windows.Platform
   1 | 
   2 | import IotaTime.TimeZone.Core
   3 | import IotaTime.TimeZone.Error
   4 | import IotaTime.Tzdb.Metadata
   5 | import IotaTime.Tzdb.Provider
   6 | import IotaTime.Tzdb.Windows
   7 | import IotaTime.Tzdb.Windows.Types
   8 | import Data.List
   9 | import Data.Either
  10 | 
  11 | %default total
  12 | 
  13 | %foreign "C:iotatime_windows_registry_snapshot, libiotatime_windows"
  14 | prim__windowsRegistrySnapshot : PrimIO AnyPtr
  15 | 
  16 | %foreign "C:iotatime_windows_snapshot_string, libiotatime_windows"
  17 | prim__windowsSnapshotString : AnyPtr -> String
  18 | 
  19 | %foreign "C:iotatime_windows_snapshot_free, libiotatime_windows"
  20 | prim__windowsSnapshotFree : AnyPtr -> PrimIO ()
  21 | 
  22 | %foreign "C:iotatime_windows_iana_to_windows, libiotatime_windows"
  23 | prim__windowsIanaToWindows : String -> PrimIO AnyPtr
  24 | 
  25 | %foreign "C:iotatime_windows_windows_to_iana, libiotatime_windows"
  26 | prim__windowsWindowsToIana : String -> PrimIO AnyPtr
  27 | 
  28 | convertZoneId : (String -> PrimIO AnyPtr) -> String -> IO (Maybe String)
  29 | convertZoneId convert value = do
  30 |   pointer <- primIO (convert value)
  31 |   if prim__nullAnyPtr pointer /= 0
  32 |     then pure Nothing
  33 |     else do
  34 |       let converted = prim__windowsSnapshotString pointer
  35 |       primIO (prim__windowsSnapshotFree pointer)
  36 |       pure (Just converted)
  37 | 
  38 | ianaToWindowsZone : String -> IO (Maybe String)
  39 | ianaToWindowsZone = convertZoneId prim__windowsIanaToWindows
  40 | 
  41 | windowsToIanaZone : String -> IO (Maybe String)
  42 | windowsToIanaZone = convertZoneId prim__windowsWindowsToIana
  43 | 
  44 | ||| Native Windows adapters provide one atomic registry snapshot containing
  45 | ||| both the available zones and locally configured Windows zone identifier.
  46 | export
  47 | record WindowsRegistrySource where
  48 |   constructor MkWindowsRegistrySource
  49 |   sourceRegistrySnapshot : IO (Either String WindowsRegistrySnapshot)
  50 | 
  51 | export
  52 | windowsRegistrySource : IO (Either String WindowsRegistrySnapshot) ->
  53 |                         WindowsRegistrySource
  54 | windowsRegistrySource = MkWindowsRegistrySource
  55 | 
  56 | windowsRegistrySnapshot : WindowsRegistrySource ->
  57 |                           IO (Either TzdbError WindowsRegistrySnapshot)
  58 | windowsRegistrySnapshot source = do
  59 |   loaded <- source.sourceRegistrySnapshot
  60 |   pure (mapFst WindowsRegistrySourceError loaded)
  61 | 
  62 | windowsRegistryZones : WindowsRegistrySource ->
  63 |                        IO (Either TzdbError (List WindowsRegistryZone))
  64 | windowsRegistryZones source = map (map snapshotZones)
  65 |   (windowsRegistrySnapshot source)
  66 | 
  67 | findWindowsZone : String -> List WindowsRegistryZone ->
  68 |                   Maybe WindowsRegistryZone
  69 | findWindowsZone name [] = Nothing
  70 | findWindowsZone name (zone :: rest) =
  71 |   if zone.registryZoneId == name then Just zone else findWindowsZone name rest
  72 | 
  73 | windowsRegistryNamedZone : WindowsRegistrySource -> String ->
  74 |                            IO (Either TzdbError TimeZone)
  75 | windowsRegistryNamedZone source name = do
  76 |   converted <- ianaToWindowsZone name
  77 |   loaded <- windowsRegistryZones source
  78 |   let registryName = case converted of
  79 |         Nothing => name
  80 |         Just value => value
  81 |   pure $ do
  82 |     zones <- loaded
  83 |     registry <- case findWindowsZone registryName zones of
  84 |       Nothing => Left (WindowsZoneNotFound name)
  85 |       Just value => Right value
  86 |     mapFst TzdbWindowsError (windowsRegistryTimeZoneAs name registry)
  87 | 
  88 | windowsRegistryLocalZone : WindowsRegistrySource ->
  89 |                            IO (Either TzdbError TimeZone)
  90 | windowsRegistryLocalZone source = do
  91 |   loaded <- windowsRegistrySnapshot source
  92 |   case loaded of
  93 |     Left error => pure (Left error)
  94 |     Right snapshot => do
  95 |       canonical <- windowsToIanaZone snapshot.snapshotLocalZoneId
  96 |       let valueId = case canonical of
  97 |             Nothing => snapshot.snapshotLocalZoneId
  98 |             Just value => value
  99 |       pure $ do
 100 |         registry <- case findWindowsZone snapshot.snapshotLocalZoneId
 101 |           snapshot.snapshotZones of
 102 |             Nothing => Left (WindowsZoneNotFound snapshot.snapshotLocalZoneId)
 103 |             Just value => Right value
 104 |         mapFst TzdbWindowsError (windowsRegistryTimeZoneAs valueId registry)
 105 | 
 106 | windowsRegistryAvailableZones : WindowsRegistrySource ->
 107 |                                 IO (Either TzdbError (List String))
 108 | windowsRegistryAvailableZones source = do
 109 |   loaded <- windowsRegistryZones source
 110 |   pure (map (sort . map registryZoneId) loaded)
 111 | 
 112 | ||| Build a provider around a Windows registry reader.
 113 | export
 114 | windowsRegistryTimeZoneProvider : WindowsRegistrySource -> TimeZoneProviderRep
 115 | windowsRegistryTimeZoneProvider source = timeZoneProvider
 116 |   (pure (Right (fixedTimeZone "UTC" empty)))
 117 |   (windowsRegistryNamedZone source)
 118 |   (windowsRegistryLocalZone source)
 119 |   (windowsRegistryAvailableZones source)
 120 |   (pure (Right (MkTzdbMetadata Nothing [])))
 121 | 
 122 | ||| Read a registry source once and return a provider with a consistent,
 123 | ||| immutable view of its zones and local-zone identifier.
 124 | export
 125 | windowsRegistrySnapshotProvider : WindowsRegistrySource ->
 126 |                                   IO (Either TzdbError TimeZoneProviderRep)
 127 | windowsRegistrySnapshotProvider source = do
 128 |   loaded <- windowsRegistrySnapshot source
 129 |   pure $ map
 130 |     (\snapshot => windowsRegistryTimeZoneProvider
 131 |       (MkWindowsRegistrySource (pure (Right snapshot))))
 132 |     loaded
 133 | 
 134 | protocolErrorMessage : WindowsRegistryProtocolError -> String
 135 | protocolErrorMessage MissingLocalZoneId = "missing local Windows zone identifier"
 136 | protocolErrorMessage (UnexpectedRegistryLine line) =
 137 |   "unexpected Windows registry output: " ++ line
 138 | protocolErrorMessage (InvalidRegistryHex value) =
 139 |   "invalid Windows registry hex value: " ++ value
 140 | protocolErrorMessage (InvalidDynamicRegistryLine line) =
 141 |   "invalid Windows Dynamic DST output: " ++ line
 142 | protocolErrorMessage IncompleteRegistryZone = "incomplete Windows registry zone"
 143 | 
 144 | nativeError : String -> Maybe String
 145 | nativeError source = map pack (strip (unpack "ERROR\t") (unpack source))
 146 |   where
 147 |     strip : List Char -> List Char -> Maybe (List Char)
 148 |     strip [] remaining = Just remaining
 149 |     strip (expected :: rest) (actual :: remaining) =
 150 |       if expected == actual then strip rest remaining else Nothing
 151 |     strip _ _ = Nothing
 152 | 
 153 | runWindowsNativeRegistry : IO (Either String WindowsRegistrySnapshot)
 154 | runWindowsNativeRegistry = do
 155 |   pointer <- primIO prim__windowsRegistrySnapshot
 156 |   if prim__nullAnyPtr pointer /= 0
 157 |     then pure (Left "native Windows registry snapshot allocation failed")
 158 |     else do
 159 |       let output = prim__windowsSnapshotString pointer
 160 |       primIO (prim__windowsSnapshotFree pointer)
 161 |       pure $ case nativeError output of
 162 |         Just error => Left error
 163 |         Nothing => case parseWindowsRegistrySnapshot output of
 164 |           Left error => Left (protocolErrorMessage error)
 165 |           Right snapshot => Right snapshot
 166 | 
 167 | ||| Registry source backed by Win32 registry APIs through the native FFI.
 168 | export
 169 | windowsNativeRegistrySource : WindowsRegistrySource
 170 | windowsNativeRegistrySource = MkWindowsRegistrySource
 171 |   runWindowsNativeRegistry
 172 |