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

import Control.Concurrent
import Control.Monad
import qualified Data.ByteString.Char8 as B
import Data.IORef
import Data.Time.Clock       (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import System.IO.Unsafe

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 now <- IO POSIXTime
getPOSIXTime
       return (now, B.pack $ formatHttpDate (posixSecondsToUTCTime 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
  (now, httpDate) <- IO (POSIXTime, ByteString)
mkTime
  nowRef      <- newIORef now
  httpDateRef <- newIORef httpDate
  let dateCache = (IORef POSIXTime -> IORef ByteString -> DateCache
DateCache IORef POSIXTime
nowRef IORef ByteString
httpDateRef)
  void $ forkIO $ updater dateCache
  return 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
       (now, httpDate) <- IO (POSIXTime, ByteString)
mkTime
       writeIORef (cachedPOSIXTime dateCache) now
       writeIORef (cachedHttpDate  dateCache) httpDate
       updater 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