{-# LANGUAGE CPP #-}
{-# OPTIONS -fno-cse #-}
module Happstack.Server.Internal.Clock
    ( getApproximateTime
    , getApproximatePOSIXTime
    , getApproximateUTCTime
    , formatHttpDate
    ) where

import Control.Concurrent
import Control.Monad
import Data.IORef
import Data.Time.Clock       (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
import System.IO.Unsafe

#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (formatTime, defaultTimeLocale)
#else
import Data.Time.Format (formatTime)
import System.Locale    (defaultTimeLocale)
#endif

import qualified Data.ByteString.Char8 as B

data DateCache = DateCache {
      DateCache -> IORef POSIXTime
cachedPOSIXTime :: !(IORef POSIXTime)
    , DateCache -> IORef ByteString
cachedHttpDate  :: !(IORef B.ByteString)
    }

formatHttpDate :: UTCTime -> String
formatHttpDate :: UTCTime -> String
formatHttpDate = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%a, %d %b %Y %X GMT"
{-# INLINE formatHttpDate #-}

mkTime :: IO (POSIXTime, B.ByteString)
mkTime :: IO (POSIXTime, ByteString)
mkTime =
    do POSIXTime
now <- IO POSIXTime
getPOSIXTime
       (POSIXTime, ByteString) -> IO (POSIXTime, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (POSIXTime
now, String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
formatHttpDate (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
now))

{-# NOINLINE clock #-}
clock :: DateCache
clock :: DateCache
clock = IO DateCache -> DateCache
forall a. IO a -> a
unsafePerformIO (IO DateCache -> DateCache) -> IO DateCache -> DateCache
forall a b. (a -> b) -> a -> b
$ do
  (POSIXTime
now, ByteString
httpDate) <- IO (POSIXTime, ByteString)
mkTime
  IORef POSIXTime
nowRef      <- POSIXTime -> IO (IORef POSIXTime)
forall a. a -> IO (IORef a)
newIORef POSIXTime
now
  IORef ByteString
httpDateRef <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
httpDate
  let dateCache :: DateCache
dateCache = (IORef POSIXTime -> IORef ByteString -> DateCache
DateCache IORef POSIXTime
nowRef IORef ByteString
httpDateRef)
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ DateCache -> IO ()
updater DateCache
dateCache
  DateCache -> IO DateCache
forall (m :: * -> *) a. Monad m => a -> m a
return DateCache
dateCache

updater :: DateCache -> IO ()
updater :: DateCache -> IO ()
updater DateCache
dateCache =
    do Int -> IO ()
threadDelay (Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)) -- Every second
       (POSIXTime
now, ByteString
httpDate) <- IO (POSIXTime, ByteString)
mkTime
       IORef POSIXTime -> POSIXTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DateCache -> IORef POSIXTime
cachedPOSIXTime DateCache
dateCache) POSIXTime
now
       IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (DateCache -> IORef ByteString
cachedHttpDate  DateCache
dateCache) ByteString
httpDate
       DateCache -> IO ()
updater DateCache
dateCache

getApproximateTime :: IO B.ByteString
getApproximateTime :: IO ByteString
getApproximateTime = IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef (DateCache -> IORef ByteString
cachedHttpDate DateCache
clock)

getApproximatePOSIXTime :: IO POSIXTime
getApproximatePOSIXTime :: IO POSIXTime
getApproximatePOSIXTime = IORef POSIXTime -> IO POSIXTime
forall a. IORef a -> IO a
readIORef (DateCache -> IORef POSIXTime
cachedPOSIXTime DateCache
clock)

getApproximateUTCTime :: IO UTCTime
getApproximateUTCTime :: IO UTCTime
getApproximateUTCTime = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> IO POSIXTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime
getApproximatePOSIXTime