1 {-# LANGUAGE BangPatterns #-}
    2 {-# LANGUAGE CPP          #-}
    3 
    4 module Snap.Internal.Http.Server.Date
    5   ( getDateString
    6   , getLogDateString
    7   ) where
    8 
    9 ------------------------------------------------------------------------------
   10 import           Control.Exception        (mask_)
   11 import           Control.Monad            (when)
   12 import           Data.ByteString          (ByteString)
   13 import           Data.IORef               (IORef, newIORef, readIORef, writeIORef)
   14 import           Foreign.C.Types          (CTime)
   15 import           System.IO.Unsafe         (unsafePerformIO)
   16 import           System.PosixCompat.Time  (epochTime)
   17 ------------------------------------------------------------------------------
   18 import           Snap.Internal.Http.Types (formatHttpTime, formatLogTime)
   19 
   20 
   21 ------------------------------------------------------------------------------
   22 data DateState = DateState {
   23       _cachedDateString :: !(IORef ByteString)
   24     , _cachedLogString  :: !(IORef ByteString)
   25     , _lastFetchTime    :: !(IORef CTime)
   26     }
   27 
   28 
   29 ------------------------------------------------------------------------------
   30 dateState :: DateState
   31 dateState = unsafePerformIO $ do
   32     (s1, s2, date) <- fetchTime
   33     bs1 <- newIORef $! s1
   34     bs2 <- newIORef $! s2
   35     dt  <- newIORef $! date
   36 
   37     return $! DateState bs1 bs2 dt
   38 {-# NOINLINE dateState #-}
   39 
   40 
   41 ------------------------------------------------------------------------------
   42 fetchTime :: IO (ByteString,ByteString,CTime)
   43 fetchTime = do
   44     !now <- epochTime
   45     !t1  <- formatHttpTime now
   46     !t2  <- formatLogTime now
   47     let !out = (t1, t2, now)
   48     return out
   49 
   50 
   51 ------------------------------------------------------------------------------
   52 updateState :: DateState -> IO ()
   53 updateState (DateState dateString logString time) = do
   54     (s1, s2, now) <- fetchTime
   55     writeIORef dateString $! s1
   56     writeIORef logString  $! s2
   57     writeIORef time       $! now
   58 
   59     return $! ()
   60 
   61 
   62 ------------------------------------------------------------------------------
   63 ensureFreshDate :: IO ()
   64 ensureFreshDate = mask_ $ do
   65     now <- epochTime
   66     old <- readIORef $ _lastFetchTime dateState
   67     when (now > old) $! updateState dateState
   68 
   69 
   70 ------------------------------------------------------------------------------
   71 getDateString :: IO ByteString
   72 getDateString = mask_ $ do
   73     ensureFreshDate
   74     readIORef $ _cachedDateString dateState
   75 
   76 
   77 ------------------------------------------------------------------------------
   78 getLogDateString :: IO ByteString
   79 getLogDateString = mask_ $ do
   80     ensureFreshDate
   81     readIORef $ _cachedLogString dateState