{-# 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
(ByteString
s1, ByteString
s2, EpochTime
date) <- IO (ByteString, ByteString, EpochTime)
fetchTime
IORef ByteString
bs1 <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef (ByteString -> IO (IORef ByteString))
-> ByteString -> IO (IORef ByteString)
forall a b. (a -> b) -> a -> b
$! ByteString
s1
IORef ByteString
bs2 <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef (ByteString -> IO (IORef ByteString))
-> ByteString -> IO (IORef ByteString)
forall a b. (a -> b) -> a -> b
$! ByteString
s2
IORef EpochTime
dt <- EpochTime -> IO (IORef EpochTime)
forall a. a -> IO (IORef a)
newIORef (EpochTime -> IO (IORef EpochTime))
-> EpochTime -> IO (IORef EpochTime)
forall a b. (a -> b) -> a -> b
$! EpochTime
date
DateState -> IO DateState
forall (m :: * -> *) a. Monad m => a -> m a
return (DateState -> IO DateState) -> DateState -> IO DateState
forall a b. (a -> b) -> a -> b
$! IORef ByteString
-> IORef ByteString -> IORef EpochTime -> DateState
DateState IORef ByteString
bs1 IORef ByteString
bs2 IORef EpochTime
dt
{-# NOINLINE dateState #-}
fetchTime :: IO (ByteString,ByteString,CTime)
fetchTime :: IO (ByteString, ByteString, EpochTime)
fetchTime = do
!EpochTime
now <- IO EpochTime
epochTime
!ByteString
t1 <- EpochTime -> IO ByteString
formatHttpTime EpochTime
now
!ByteString
t2 <- EpochTime -> IO ByteString
formatLogTime EpochTime
now
let !out :: (ByteString, ByteString, EpochTime)
out = (ByteString
t1, ByteString
t2, EpochTime
now)
(ByteString, ByteString, EpochTime)
-> IO (ByteString, ByteString, EpochTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString, ByteString, EpochTime)
out
updateState :: DateState -> IO ()
updateState :: DateState -> IO ()
updateState (DateState IORef ByteString
dateString IORef ByteString
logString IORef EpochTime
time) = do
(ByteString
s1, ByteString
s2, EpochTime
now) <- IO (ByteString, ByteString, EpochTime)
fetchTime
IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
dateString (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$! ByteString
s1
IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
logString (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$! ByteString
s2
IORef EpochTime -> EpochTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef EpochTime
time (EpochTime -> IO ()) -> EpochTime -> IO ()
forall a b. (a -> b) -> a -> b
$! EpochTime
now
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! ()
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
EpochTime
now <- IO EpochTime
epochTime
EpochTime
old <- IORef EpochTime -> IO EpochTime
forall a. IORef a -> IO a
readIORef (IORef EpochTime -> IO EpochTime)
-> IORef EpochTime -> IO EpochTime
forall a b. (a -> b) -> a -> b
$ DateState -> IORef EpochTime
_lastFetchTime DateState
dateState
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EpochTime
now EpochTime -> EpochTime -> Bool
forall a. Ord a => a -> a -> Bool
> EpochTime
old) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$! DateState -> IO ()
updateState DateState
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