2013-12-14-acid-state.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

import Control.Applicative
import Control.Monad.Reader (ask)
import Control.Monad.State (modify)
import Data.Acid
import Data.Function
import Data.IntMap (IntMap)
import Data.List
import Data.Ord
import Data.SafeCopy
import Data.Typeable
import Data.Time

import qualified Data.IntMap as IntMap

data Failure = Failure { failureReason :: String
                       , failureTime :: UTCTime
                       } deriving (Show, Typeable)

data FailureDb = FailureDb { allFailures :: IntMap Failure }
  deriving (Typeable)

failuresOverTime :: Query FailureDb [Failure]
failuresOverTime =
  sortBy (comparing failureTime) . IntMap.elems . allFailures <$> ask

addFailure :: Failure -> Update FailureDb ()
addFailure failure = modify go
 where
  go (FailureDb db) = FailureDb $
    case IntMap.maxViewWithKey db of
      Just ((max, _), _) -> IntMap.insert (max + 1) failure db
      Nothing            -> IntMap.singleton 1 failure

deriveSafeCopy 0 'base ''Failure
deriveSafeCopy 0 'base ''FailureDb
makeAcidic ''FailureDb ['failuresOverTime, 'addFailure]

main :: IO ()
main = do
  state <- openLocalState (FailureDb IntMap.empty)

  -- Record a new failure
  now <- getCurrentTime
  update state (AddFailure $ Failure "ENOMISSLES" now)

  -- Query for all failures
  allFailures <- query state FailuresOverTime
  
  mapM_ print allFailures