1 {-# LANGUAGE BangPatterns #-}
    2 {-# LANGUAGE CPP #-}
    3 
    4 module Snap.Internal.Http.Server.Date
    5 ( getDateString
    6 , getLogDateString
    7 , getCurrentDateTime) where
    8 
    9 import           Control.Concurrent
   10 import           Control.Exception
   11 import           Control.Monad
   12 import           Data.ByteString (ByteString)
   13 import           Data.IORef
   14 import           Data.Maybe
   15 import           Foreign.C.Types
   16 import           System.IO.Unsafe
   17 import           System.PosixCompat.Time
   18 
   19 import           Snap.Internal.Http.Types (formatHttpTime, formatLogTime)
   20 
   21 -- Here comes a dirty hack. We don't want to be wasting context switches
   22 -- building date strings, so we're only going to compute one every two
   23 -- seconds. (Approximate timestamps to within a couple of seconds are OK here,
   24 -- and we'll reduce overhead.)
   25 --
   26 -- Note that we also don't want to wake up a potentially sleeping CPU by just
   27 -- running the computation on a timer. We'll allow client traffic to trigger
   28 -- the process.
   29 
   30 ------------------------------------------------------------------------------
   31 data DateState = DateState {
   32       _cachedDateString :: !(IORef ByteString)
   33     , _cachedLogString  :: !(IORef ByteString)
   34     , _cachedDate       :: !(IORef CTime)
   35     , _valueIsOld       :: !(IORef Bool)
   36     , _morePlease       :: !(MVar ())
   37     , _dateThread       :: !(MVar ThreadId)
   38     }
   39 
   40 
   41 ------------------------------------------------------------------------------
   42 dateState :: DateState
   43 dateState = unsafePerformIO $ do
   44     (s1,s2,date) <- fetchTime
   45     bs1 <- newIORef s1
   46     bs2 <- newIORef s2
   47     dt  <- newIORef date
   48     ov  <- newIORef False
   49     th  <- newEmptyMVar
   50     mp  <- newMVar ()
   51 
   52     let d = DateState bs1 bs2 dt ov mp th
   53 
   54     t  <- forkIO $ dateThread d
   55     putMVar th t
   56 
   57     return d
   58 
   59 
   60 ------------------------------------------------------------------------------
   61 fetchTime :: IO (ByteString,ByteString,CTime)
   62 fetchTime = do
   63     now <- epochTime
   64     t1  <- formatHttpTime now
   65     t2  <- formatLogTime now
   66     return (t1, t2, now)
   67 
   68 
   69 ------------------------------------------------------------------------------
   70 updateState :: DateState -> IO ()
   71 updateState (DateState dateString logString time valueIsOld _ _) = do
   72     (s1,s2,now) <- fetchTime
   73     atomicModifyIORef dateString $ const (s1,())
   74     atomicModifyIORef logString  $ const (s2,())
   75     atomicModifyIORef time       $ const (now,())
   76     writeIORef valueIsOld False
   77 
   78     -- force values in the iorefs to prevent thunk buildup
   79     !_ <- readIORef dateString
   80     !_ <- readIORef logString
   81     !_ <- readIORef time
   82 
   83     return ()
   84 
   85 
   86 ------------------------------------------------------------------------------
   87 dateThread :: DateState -> IO ()
   88 dateThread ds@(DateState _ _ _ valueIsOld morePlease _) = loop
   89   where
   90     loop = do
   91         b <- tryTakeMVar morePlease
   92         when (isNothing b) $ do
   93             writeIORef valueIsOld True
   94             takeMVar morePlease
   95 
   96         updateState ds
   97         threadDelay 2000000
   98         loop
   99 
  100 
  101 ------------------------------------------------------------------------------
  102 ensureFreshDate :: IO ()
  103 ensureFreshDate = block $ do
  104     old <- readIORef $ _valueIsOld dateState
  105     _ <- tryPutMVar (_morePlease dateState) ()
  106 
  107     -- if the value is not fresh we will tickle the date thread but also fetch
  108     -- the new value immediately; we used to block but we'll do a little extra
  109     -- work to avoid a delay
  110     when old $ updateState dateState
  111 
  112 
  113 ------------------------------------------------------------------------------
  114 getDateString :: IO ByteString
  115 getDateString = block $ do
  116     ensureFreshDate
  117     readIORef $ _cachedDateString dateState
  118 
  119 
  120 ------------------------------------------------------------------------------
  121 getLogDateString :: IO ByteString
  122 getLogDateString = block $ do
  123     ensureFreshDate
  124     readIORef $ _cachedLogString dateState
  125 
  126 
  127 ------------------------------------------------------------------------------
  128 getCurrentDateTime :: IO CTime
  129 getCurrentDateTime = block $ do
  130     ensureFreshDate
  131     readIORef $ _cachedDate dateState