happs-hsp-template-0.2: src/HAppS/Template/HSP.hs

module HAppS.Template.HSP
     ( WebState(..)
     , Web
     , runWeb
     , runWebXML
     , globalQuery
     , globalRead
     , simpleRequest
     , localQuery
     , localRead
     ) where

import Text.RJson
import Control.Monad.Reader
import Control.Monad.Writer

import Data.Monoid
import qualified Data.Map as Map

import qualified Data.ByteString.Lazy as Lazy

import HAppS.Server.SimpleHTTP (Request(..),Method(..),Input,Cookie,RqBody(..))
import HAppS.Server.MessageWrap
import HAppS.Server.SURI
import Network.URI (parseRelativeReference,uriQuery)

import HSP hiding (Request)

nullRequest :: Request
nullRequest = Request { rqMethod = GET
                      , rqPaths = []
                      , rqQuery = "/"
                      , rqInputs = []
                      , rqCookies = []
                      , rqVersion = error "version not set"
                      , rqHeaders = error "headers not set"
                      , rqBody = Body Lazy.empty
                      , rqPeer = ("localhost", 0) }

simpleRequest :: String -> Request
simpleRequest query = case parseRelativeReference query of
                        Nothing -> nullRequest
                        Just uri -> nullRequest{rqQuery = uriQuery uri
                                               ,rqPaths = pathEls (path $ SURI uri)
                                               ,rqInputs = queryInput (SURI uri)}

data WebState
    = WebState
    { queryGlobal :: Request -> IO JsonData
    , queryLocal :: Map.Map String JsonData }

type Web = HSPT (WriterT (Endo XML) (ReaderT WebState IO))

runWeb :: WebState -> Web a -> HSP a
runWeb st web
    = do env <- getEnv
         (xml,Endo w) <- liftIO $ runReaderT (runWriterT $ runHSPT web env) st
         return $ xml

runWebXML :: WebState -> Web XML -> HSP XML
runWebXML st web
    = do env <- getEnv
         (xml,Endo w) <- liftIO $ runReaderT (runWriterT $ runHSPT web env) st
         return $ w xml

globalQuery :: Request -> Web JsonData
globalQuery key
    = do fn <- lift $ lift $ asks queryGlobal
         liftIO $ fn key

localQuery :: String -> Web JsonData
localQuery key
    = do m <- lift $ lift $ asks queryLocal
         return $ Map.findWithDefault (JDString $ "Lookup failed: " ++ key) key m

globalRead :: FromJson a => Request -> Web a
globalRead key = do json <- globalQuery key
                    case fromJson undefined json of
                      Left err  -> error err
                      Right val -> return val

localRead :: FromJson a => String -> Web a
localRead key = do json <- localQuery key
                   case fromJson undefined json of
                     Left err  -> error err
                     Right val -> return val