Phsu-0.1.0.1: src/BoilerplateDB.hs

{-# LANGUAGE DeriveDataTypeable, FlexibleContexts
  , GeneralizedNewtypeDeriving, MultiParamTypeClasses
  , OverloadedStrings, ScopedTypeVariables, TemplateHaskell
  , TypeFamilies, FlexibleInstances #-}

module BoilerplateDB (withAcid, runApp, App,
		URLSubDb, URLSub, exportURLSub, exportAllURLSubRules, exportUpdateURLSub, exportAddURLSub, exportRemoveURLSub, exportHitRule, exportReorderURLSub,
		regex, substitute, ruleId, hits,
		GithubSettings, exportGithubSetting, exportUpdateGithubSetting,
		ghHandle, ghToken, allGhUsers
		) where

import Control.Applicative (Applicative, Alternative, (<$>))
import Control.Exception.Lifted (bracket)
import Control.Monad (MonadPlus)
import Control.Monad.Reader (MonadReader, ReaderT(..), ask)
import Control.Monad.State (modify)
import Control.Monad.Trans (MonadIO(..))
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Acid (AcidState(..), EventState(..), EventResult(..), Query(..), QueryEvent(..), Update(..), UpdateEvent(..), IsAcidic(..), makeAcidic, openLocalState)
import Data.Acid.Advanced (query', update')
import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom)
import Data.Data (Data, Typeable)
import Data.IntMap (IntMap)
import Data.IntMap as IntMap
import Data.List (sortBy)
import Data.Map (Map)
import Data.Maybe (fromMaybe, listToMaybe, catMaybes)
import Data.Ord (comparing)
import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)
import Happstack.Server (Happstack, HasRqData, Response, ServerPartT(..), WebMonad, FilterMonad, ServerMonad, mapServerPartT)
import Prelude hiding (head, id)
import System.FilePath ((</>))
import qualified Data.Map as Map

-- begin boiler plate for Acid State
class HasAcidState m st where
	getAcidState :: m (AcidState st)

query :: forall event m.
         ( Functor m
         , MonadIO m
         , QueryEvent event
         , HasAcidState m (EventState event)
         ) =>
         event
      -> m (EventResult event)
query event =
    do as <- getAcidState
       query' (as :: AcidState (EventState event)) event

update :: forall event m.
          ( Functor m
          , MonadIO m
          , UpdateEvent event
          , HasAcidState m (EventState event)
          ) =>
          event
       -> m (EventResult event)
update event =
    do as <- getAcidState
       update' (as :: AcidState (EventState event)) event

-- automatically creates a checkpoint on close
withLocalState
  :: ( MonadBaseControl IO m
     , MonadIO m
     , IsAcidic st
     , Typeable st
     ) =>
     Maybe FilePath        -- ^ path to state directory
  -> st                    -- ^ initial state value
  -> (AcidState st -> m a) -- ^ function which uses the
                           --   `AcidState` handle
  -> m a
withLocalState mPath initialState =
  bracket (liftIO $ open initialState)
          (liftIO . createCheckpointAndClose)
  where
    open = maybe openLocalState openLocalStateFrom mPath
-- end boiler plate

-- user defined AcidState (URLSubDb) and functions on them
data URLSub = URLSub { regex :: 			String
					 , substitute:: 		String
					 , hits:: 				Int
					 , ruleId::				Int
                     } deriving (Show, Typeable)

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

initialRulesState :: URLSubDb
initialRulesState = URLSubDb { allRules = IntMap.empty }

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

hitRule :: Int -> Update URLSubDb ()
hitRule ruleId = modify go where
	go (URLSubDb db) = URLSubDb $ IntMap.adjust (\old_rule -> old_rule{hits=(1+(hits old_rule))}) ruleId db


reorderURLSub :: (IntMap Int) -> Update URLSubDb ()
reorderURLSub mapping = modify go where
	go (URLSubDb db) = URLSubDb . IntMap.fromList . elems . (IntMap.map mymapping) $ db where
		valid = IntMap.null $ IntMap.difference db mapping
		mymapping rule =
			let new_id = if valid then (IntMap.!) mapping $ ruleId rule else ruleId rule
			in (new_id, rule{ruleId=new_id})

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, 'hitRule, 'reorderURLSub]

exportAllURLSubRules:: (HasAcidState m URLSubDb, MonadIO m, Functor m) => m (EventResult AllURLSubRules)
exportAllURLSubRules = query AllURLSubRules

exportUpdateURLSub x = BoilerplateDB.update $ UpdateURLSub x
exportAddURLSub x = BoilerplateDB.update $ AddURLSub x
exportRemoveURLSub x = BoilerplateDB.update $ RemoveURLSub x
exportHitRule x = BoilerplateDB.update $ HitRule x
exportReorderURLSub x = BoilerplateDB.update $ ReorderURLSub x
exportURLSub r s i j = URLSub r s i j
-- end user defined AcidState URLSubDb

-- begin user defined AcidState GithubSettings
data GithubSettings = GithubSettings {
		ghHandle :: Maybe String,
		ghToken :: Maybe String,
		allGhUsers :: Maybe (Map String [String])
	} deriving (Show, Typeable)

initialGithubState :: GithubSettings
initialGithubState = GithubSettings { ghHandle = Nothing, ghToken = Nothing, allGhUsers = Just Map.empty }

ghSetting :: Query GithubSettings GithubSettings
ghSetting = ask

updateGithubSetting :: GithubSettings -> Update GithubSettings ()
updateGithubSetting setting = modify go
  where
    go originalSetting = originalSetting {ghHandle = extract ghHandle, ghToken = extract ghToken, allGhUsers = listToMaybe . catMaybes $ [allGhUsers setting, allGhUsers originalSetting]} where
        extract h = listToMaybe . catMaybes $ [h setting, h originalSetting]

$(deriveSafeCopy 0 'base ''GithubSettings)
makeAcidic ''GithubSettings ['ghSetting, 'updateGithubSetting]

exportGithubSetting:: (HasAcidState m GithubSettings, MonadIO m, Functor m) => m (EventResult GhSetting)
exportGithubSetting = query GhSetting
exportUpdateGithubSetting x = BoilerplateDB.update $ UpdateGithubSetting x
-- end user defined AcidState GithubSettings

-- boiler-plate - bundle up into an Acid
data Acid = Acid
   { urlSubRules :: AcidState URLSubDb,
     githubSettings :: AcidState GithubSettings }

withAcid :: Maybe FilePath -> (Acid -> IO a) -> IO a
withAcid mBasePath action =
  let basePath = fromMaybe "state" mBasePath
      rulesPath = Just $ basePath </> "rules"
      githubPath = Just $ basePath </> "github_settings"
  in  withLocalState rulesPath initialRulesState $ \c ->
      withLocalState githubPath initialGithubState $ \d ->
          action (Acid c d)
-- end boiler-plate

-- more boiler plate, define an App
newtype App a = App { unApp :: ServerPartT (ReaderT Acid IO) a }
    deriving ( Functor, Alternative, Applicative, Monad
             , MonadPlus, MonadIO, HasRqData, ServerMonad
             , WebMonad Response, FilterMonad Response
             , Happstack, MonadReader Acid
             )

runApp :: Acid -> App a -> ServerPartT IO a
runApp acid (App sp) =
    mapServerPartT (flip runReaderT acid) sp
-- end boiler plate: define an App

instance HasAcidState App URLSubDb where getAcidState = urlSubRules <$> ask
instance HasAcidState App GithubSettings where getAcidState = githubSettings <$> ask