Phsu-0.1.0.1: src/DBSupport.hs

{-# LANGUAGE DeriveDataTypeable, FlexibleContexts
  , GeneralizedNewtypeDeriving, MultiParamTypeClasses
  , OverloadedStrings, ScopedTypeVariables, TemplateHaskell
  , TypeFamilies, FlexibleInstances #-}
module Main where
import Control.Applicative
import Control.Monad.Reader (ask)
import Control.Monad.State (modify)
import Data.Acid
import Data.Function
import Data.IntMap (IntMap, delete, adjust)
import Data.List
import Data.Ord
import Data.SafeCopy
import Data.Time
import Data.Typeable
import qualified Data.IntMap as IntMap

data URLSub = URLSub { regex :: 			String
					 , substitute::  	String
					 , hits:: 			Int
					 , ruleId::				Int
                     } deriving (Show, Typeable)

data URLSubDb = URLSubDb { allRules :: IntMap URLSub }
  deriving (Typeable)

allURLSubRules :: Query URLSubDb [URLSub]
allURLSubRules =
  sortBy (comparing $ \x -> - (hits x)) . IntMap.elems . allRules <$> ask

addURLSub :: URLSub -> Update URLSubDb ()
addURLSub rule = modify go
 where
  go (URLSubDb db) = URLSubDb $
    case IntMap.maxViewWithKey db of
      Just ((max, _), _) -> IntMap.insert (max + 1) rule{hits=0, ruleId=max+1} db
      Nothing            -> IntMap.singleton 1 rule{hits=0, ruleId=1}

removeURLSub :: Int -> Update URLSubDb ()
removeURLSub ruleId = modify go
 where
  go (URLSubDb db) = URLSubDb $ IntMap.delete ruleId db

updateURLSub :: URLSub -> Update URLSubDb ()
updateURLSub rule = modify go
 where
  go (URLSubDb db) = URLSubDb $ IntMap.adjust (\old_rule -> old_rule{regex=(regex rule), substitute=(substitute rule)}) (ruleId rule) db

$(deriveSafeCopy 0 'base ''URLSub)
$(deriveSafeCopy 0 'base ''URLSubDb)
makeAcidic ''URLSubDb ['allURLSubRules , 'addURLSub, 'removeURLSub, 'updateURLSub]

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

  -- Record a new failure
  -- update state (AddURLSub $ URLSub "TEST" "Sub" 9 4)
  -- update state (RemoveURLSub 5)
  -- update state (UpdateURLSub $ URLSub{regex="regex", substitute="Trauma", hits=4, ruleId=10})
  update state (AddURLSub $  URLSub{regex="c\\s?([0-9]*)L?", substitute="https://console.zenefits.com/console/company/\\1", hits=4, ruleId=10})

  -- Query for all failures
  allRules <- query state AllURLSubRules

  mapM_ print allRules