ObjectStore.hs

{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable,
    FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,
    UndecidableInstances, TypeOperators
    #-}
module App.ObjectStore
    ( objectStoreHandlers
    ) where

import Coretal.Services.OpenIDHandlers
-- import Happstack.Data
import Happstack.State
import Happstack.Server
import Data.Generics hiding ((:+:))
import Happstack.Data.IxSet
import Happstack.State hiding (Object(..))
import Control.Monad.Reader (ask)
import qualified Data.Map as M
import Control.Monad.State (modify,put,get,gets,MonadState)
import Control.Monad.Reader
import Control.Applicative
import Data.List
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Char8 as S
import Text.JSON.Generic
import System.UUID.V4 (uuid)
import App.Extensions
import App.States.ObjectStore
import Data.Maybe
import App.Views.ObjectStore
import Happstack.Server.HSP.HTML

objectStoreHandlers =
    msum [ dir "store" $
           msum [ dir "new" $ methodSP POST newHandler
                , dir "update" $ methodSP POST updateHandler
                , dir "list" $ listHandler
                , dir "stats" $ statsHandler
                ]
         , dir "view" $ webHSP page
         ]

newHandler :: ServerPart Response
newHandler = withOpenID go mzero
    where
      go :: String -> ServerPart Response
      go i = do id <- liftIO $ show <$> uuid
                let o = (Object (ObjectId id) (OpenID i) M.empty) 
                update $ UpdateObject o
                res <- query $ GetObject (ObjectId id)
                ok $ toResponse $ fromJust res

updateHandler :: ServerPart Response
updateHandler = withOpenID go mzero
    where
      toBody :: Request -> L.ByteString
      toBody rq = case rqBody rq of
                    Body b -> b
      go i = do rq <- askRq
                case decodeJSON . L.unpack . toBody $ rq of
                  o@(Object id oid attrs) -> do 
                    res <- query $ GetObject id
                    case res of
                      Nothing -> notFound $ toResponse "Object not found"
                      Just _  -> do 
                        o' <- update $ UpdateObject o
                        ok $ toResponse o'
                  _ -> badRequest $ toResponse "Cannot decode object"

-- deletePostHandler :: ServerPart Response
-- deletePostHandler = withOpenId go mzero
--     where
--       go i = do 
          
listHandler :: ServerPart Response
listHandler = do
  os <- query $ GetObjects
  ok $ toResponse os

statsHandler :: ServerPart Response
statsHandler = do
  os <- query $ GetObjects
  ok $ toResponse $ "Total Objects: " ++ (show $ length os)