{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP          #-}

module Snap.Internal.Http.Server.Date
  ( getDateString
  , getLogDateString
  ) where

------------------------------------------------------------------------------
import           Control.Exception        (mask_)
import           Control.Monad            (when)
import           Data.ByteString          (ByteString)
import           Data.IORef               (IORef, newIORef, readIORef, writeIORef)
import           Foreign.C.Types          (CTime)
import           System.IO.Unsafe         (unsafePerformIO)
import           System.PosixCompat.Time  (epochTime)
------------------------------------------------------------------------------
import           Snap.Internal.Http.Types (formatHttpTime, formatLogTime)


------------------------------------------------------------------------------
data DateState = DateState {
      DateState -> IORef ByteString
_cachedDateString :: !(IORef ByteString)
    , DateState -> IORef ByteString
_cachedLogString  :: !(IORef ByteString)
    , DateState -> IORef EpochTime
_lastFetchTime    :: !(IORef CTime)
    }


------------------------------------------------------------------------------
dateState :: DateState
dateState :: DateState
dateState = IO DateState -> DateState
forall a. IO a -> a
unsafePerformIO (IO DateState -> DateState) -> IO DateState -> DateState
forall a b. (a -> b) -> a -> b
$ do
    (s1, s2, date) <- IO (ByteString, ByteString, EpochTime)
fetchTime
    bs1 <- newIORef $! s1
    bs2 <- newIORef $! s2
    dt  <- newIORef $! date

    return $! DateState bs1 bs2 dt
{-# NOINLINE dateState #-}


------------------------------------------------------------------------------
fetchTime :: IO (ByteString,ByteString,CTime)
fetchTime :: IO (ByteString, ByteString, EpochTime)
fetchTime = do
    !now <- IO EpochTime
epochTime
    !t1  <- formatHttpTime now
    !t2  <- formatLogTime now
    let !out = (ByteString
t1, ByteString
t2, EpochTime
now)
    return out


------------------------------------------------------------------------------
updateState :: DateState -> IO ()
updateState :: DateState -> IO ()
updateState (DateState IORef ByteString
dateString IORef ByteString
logString IORef EpochTime
time) = do
    (s1, s2, now) <- IO (ByteString, ByteString, EpochTime)
fetchTime
    writeIORef dateString $! s1
    writeIORef logString  $! s2
    writeIORef time       $! now

    return $! ()


------------------------------------------------------------------------------
ensureFreshDate :: IO ()
ensureFreshDate :: IO ()
ensureFreshDate = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    now <- IO EpochTime
epochTime
    old <- readIORef $ _lastFetchTime dateState
    when (now > old) $! updateState dateState


------------------------------------------------------------------------------
getDateString :: IO ByteString
getDateString :: IO ByteString
getDateString = IO ByteString -> IO ByteString
forall a. IO a -> IO a
mask_ (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
    IO ()
ensureFreshDate
    IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef (IORef ByteString -> IO ByteString)
-> IORef ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ DateState -> IORef ByteString
_cachedDateString DateState
dateState


------------------------------------------------------------------------------
getLogDateString :: IO ByteString
getLogDateString :: IO ByteString
getLogDateString = IO ByteString -> IO ByteString
forall a. IO a -> IO a
mask_ (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
    IO ()
ensureFreshDate
    IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef (IORef ByteString -> IO ByteString)
-> IORef ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ DateState -> IORef ByteString
_cachedLogString DateState
dateState