{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving
  , MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TemplateHaskell
  , TypeFamilies, FlexibleInstances #-}
module Main where
import Control.Applicative  (Applicative, Alternative, (<$>))
import Control.Exception.Lifted    (bracket)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad        (MonadPlus, mplus)
import Control.Monad.Reader (MonadReader, ReaderT(..), ask)
import Control.Monad.Trans  (MonadIO(..))
import Data.Acid            ( AcidState(..), EventState(..), EventResult(..)
                            , Query(..), QueryEvent(..), Update(..), UpdateEvent(..)
                            , IsAcidic(..), makeAcidic, openLocalState
                            )
import Data.Acid.Local      ( createCheckpointAndClose
                            , openLocalStateFrom
                            )
import Data.Acid.Advanced   (query', update')
import Data.Maybe           (fromMaybe)
import Data.SafeCopy        (SafeCopy, base, deriveSafeCopy)
import Data.Data            (Data, Typeable)
import Data.Lens            ((%=), (!=))
import Data.Lens.Template   (makeLens)
import Data.Text.Lazy       (Text)
import Happstack.Server     ( Happstack, HasRqData, Method(GET, POST), Request(rqMethod)
                            , Response
                            , ServerPartT(..), WebMonad, FilterMonad, ServerMonad
                            , askRq, decodeBody, dir, defaultBodyPolicy, lookText
                            , mapServerPartT, nullConf, nullDir, ok, simpleHTTP
                            , toResponse
                            )
import Prelude hiding       (head, id)
import System.FilePath      ((</>))
import Text.Blaze           ((!))
import Text.Blaze.Html4.Strict (body, head, html, input, form, label, p, title, toHtml)
import Text.Blaze.Html4.Strict.Attributes (action, enctype, for, id, method, name, type_, value)
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
-- | bracket the opening and close of the `AcidState` handle. 

-- 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 $ (maybe openLocalState openLocalStateFrom mPath) initialState)
            (liftIO . createCheckpointAndClose)
-- State that stores a hit count

data CountState = CountState { _count :: Integer }
                deriving (Eq, Ord, Data, Typeable, Show)

$(deriveSafeCopy 0 'base ''CountState)
$(makeLens ''CountState)

initialCountState :: CountState
initialCountState = CountState { _count = 0 }

incCount :: Update CountState Integer
incCount = count %= succ

$(makeAcidic ''CountState ['incCount])
-- State that stores a greeting
data GreetingState = GreetingState {  _greeting :: Text }
                deriving (Eq, Ord, Data, Typeable, Show)

$(deriveSafeCopy 0 'base ''GreetingState)
$(makeLens ''GreetingState)

initialGreetingState :: GreetingState
initialGreetingState = GreetingState { _greeting = "Hello" }

getGreeting :: Query GreetingState Text
getGreeting = _greeting <$> ask

setGreeting :: Text -> Update GreetingState Text
setGreeting txt = greeting != txt

$(makeAcidic ''GreetingState ['getGreeting, 'setGreeting])
data Acid = Acid { acidCountState    :: AcidState CountState
                 , acidGreetingState :: AcidState GreetingState
                 }

withAcid :: Maybe FilePath -> (Acid -> IO a) -> IO a
withAcid mBasePath action =
    let basePath = fromMaybe "_state" mBasePath
    in withLocalState (Just $ basePath </> "count")    initialCountState    $ \c ->
       withLocalState (Just $ basePath </> "greeting") initialGreetingState $ \g ->
           action (Acid c g)
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
instance HasAcidState App CountState where
    getAcidState = acidCountState    <$> ask 

instance HasAcidState App GreetingState where
    getAcidState = acidGreetingState <$> ask
page :: App Response
page =
    do nullDir
       g <- greet
       c <- update IncCount -- ^ a CountState event
       ok $ toResponse $
          html $ do
            head $ do
              title "acid-state demo"
            body $ do
              form ! action "/" ! method "POST" ! enctype "multipart/form-data" $ do
                label "new message: " ! for "msg"
                input ! type_ "text" ! id "msg" ! name "greeting"
                input ! type_ "submit" ! value "update message"
              p $ toHtml g
              p $ do "This page has been loaded " 
                     toHtml c
                     " time(s)."
    where
    greet =
        do m <- rqMethod <$> askRq
           case m of
             POST -> 
                 do decodeBody (defaultBodyPolicy "/tmp/" 0 1000 1000)
                    newGreeting <- lookText "greeting"
                    update (SetGreeting newGreeting)   -- ^ a GreetingState event
                    return newGreeting
             GET  -> 
                 do query GetGreeting                  -- ^ a GreetingState event
main :: IO ()
main =
    withAcid Nothing $ \acid ->
        simpleHTTP nullConf $ runApp acid page
newtype FooState = FooState { foo :: Text }
    deriving (Eq, Ord, Data, Typeable, SafeCopy)

initialFooState :: FooState
initialFooState = FooState { foo = "foo" }

askFoo :: Query FooState Text
askFoo = foo <$> ask

$(makeAcidic ''FooState ['askFoo])
fooPlugin :: (Happstack m, HasAcidState m FooState) => m Response
fooPlugin =
    dir "foo" $ do
       txt <- query AskFoo
       ok $ toResponse txt
data Acid' = Acid' { acidCountState'    :: AcidState CountState
                   , acidGreetingState' :: AcidState GreetingState
                   , acidFooState'      :: AcidState FooState
                   }
withAcid' :: Maybe FilePath -> (Acid' -> IO a) -> IO a
withAcid' mBasePath action =
    let basePath = fromMaybe "_state" mBasePath
    in withLocalState (Just $ basePath </> "count")    initialCountState    $ \c ->
       withLocalState (Just $ basePath </> "greeting") initialGreetingState $ \g ->
       withLocalState (Just $ basePath </> "foo")      initialFooState      $ \f ->
           action (Acid' c g f)
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')

instance HasAcidState App' FooState where
    getAcidState = acidFooState' <$> ask
fooAppPlugin :: App' Response
fooAppPlugin = fooPlugin
fooReaderPlugin :: ReaderT (AcidState FooState) (ServerPartT IO) Response
fooReaderPlugin = fooPlugin
instance HasAcidState (ReaderT (AcidState FooState) (ServerPartT IO)) FooState where
    getAcidState = ask
withFooPlugin :: (MonadIO m, MonadBaseControl IO m) => 
                 FilePath                          -- ^ path to state directory
              -> (ServerPartT IO Response -> m a)  -- ^ function that uses fooPlugin
              -> m a
withFooPlugin basePath f =
       do withLocalState (Just $ basePath </> "foo") initialFooState $ \fooState -> 
              f $ runReaderT fooReaderPlugin fooState
main' :: IO ()
main' = 
    withFooPlugin "_state" $ \fooPlugin' ->
        withAcid Nothing $ \acid ->
            simpleHTTP nullConf $ fooPlugin' `mplus` runApp acid page