Cache.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Network.HxWeb.Catch
-- Copyright   :  (c) David Himmelstrup 2006
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable (requires System.Mem.StableName)
--
-----------------------------------------------------------------------------
module Network.HxWeb.Cache
    ( memoFn'
    , memoFn
    , memo
    , static
    ) where

import Network.CGI

import Data.IORef            ( IORef, newIORef, readIORef, writeIORef )
import System.Time           ( ClockTime, getClockTime, addToClockTime, TimeDiff(..) )
import System.IO.Unsafe      ( unsafePerformIO )

import qualified Data.HashTable as HT
import System.Mem.StableName
import Control.Monad
import Data.Maybe

import Network.HxWeb.Monad   ( WebPage )

{-# NOINLINE memoFn' #-}
memoFn' :: Eq a => Int -> (a -> WebPage st b) -> (a -> WebPage st b, a -> WebPage st ())
memoFn' mins webpage
    = unsafePerformIO $
      do now <- getClockTime
         let delay = TimeDiff 0 0 0 0 mins 0 0
             expire = addToClockTime delay now
         ht <- HT.new (==) (\a -> unsafePerformIO $
                                  do stableA <- makeStableName a
                                     return (HT.hashInt (hashStableName stableA)))
         ref <- newIORef expire
         return (worker delay ref ht webpage
                ,\key -> liftIO $ HT.delete ht key)

{-# INLINE memoFn #-}
memoFn :: Eq a => Int -> (a -> WebPage st b) -> (a -> WebPage st b)
memoFn mins page = fst (memoFn' mins page)

worker :: Eq a => TimeDiff -> IORef ClockTime -> HT.HashTable a b -> (a -> WebPage st b)
       -> (a -> WebPage st b)
worker delay ref ht webFunc a
    = do now <- liftIO $ getClockTime
         expire <- liftIO $ readIORef ref
         mbB <- liftIO $ HT.lookup ht a
         case mbB of
           Just b | now < expire -> return b
           _otherwise -> do b <- webFunc a
                            when (isJust mbB) $ liftIO $ writeIORef ref (addToClockTime delay now)
                            liftIO $ HT.insert ht a b
                            return b

{-
  Cache a WebPage for @n@ minutes.
-}
{-# NOINLINE memo #-}
memo :: Int -> WebPage st a -> WebPage st a
memo mins
    = unsafePerformIO $
           do now <- getClockTime
              let delay = TimeDiff 0 0 0 0 mins 0 0
                  expire = addToClockTime delay now
              ref <- newIORef (Nothing,expire)
              return (applyFn delay ref)

applyFn :: TimeDiff -> IORef (Maybe a,ClockTime) -> WebPage st a -> WebPage st a
applyFn delay ref webPage
    = do now <- liftIO $ getClockTime
         (mbA, expire) <- liftIO $ readIORef ref
         case mbA of
           Just a | now < expire -> return a
           _otherwise -> do a <- webPage
                            liftIO (writeIORef ref (Just a,addToClockTime delay now))
                            return a

{-
  Mark page as static. The WebPage will only
  be run once.
-}
{-# NOINLINE static #-}
static :: WebPage st a -> WebPage st a
static
    = unsafePerformIO $
         do ref <- newIORef Nothing
            let loop webPage
                    = do mbA <- liftIO $ readIORef ref
                         case mbA of
                           Just a -> return a
                           Nothing -> do a <- webPage
                                         liftIO (writeIORef ref (Just a))
                                         return a
            return loop