happs-tutorial-0.3: src/Misc.hs

{-# OPTIONS -fglasgow-exts -fno-monomorphism-restriction #-}
module Misc where 

import HAppS.Server 
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Monad.Trans
import Data.List

import Debug.Trace
import Text.PrettyPrint as PP

import Text.StringTemplate
import Data.Monoid
import Control.Monad.Reader

newtype HtmlString = HtmlString String
instance ToMessage HtmlString where
  toContentType _ = B.pack "text/html"
  toMessage (HtmlString s) = L.pack s 

exactdir staticPath = spsIf (\rq -> rqURL rq == staticPath) 

spsIf :: (Monad m) => (Request -> Bool) -> [ServerPartT m a] -> ServerPartT m a
spsIf p sps = withRequest $ \rq ->
  if p rq
    then unServerPartT (mconcat sps) rq
    else mempty

traceTrue x = trace (show x ++ "\n\n") True
traceIt x = trace (show x ++ "\n\n") x
traceMsg msg x = trace ( "\n\n" ++ msg ++ (show x) ++ "\n\n") x
traceReadableMsg msg x = trace ( "\n\n" ++ msg ++ (show . show $ x) ++ "\n\n") x

pp[] = ( PP.render . vcat . map text . map show )
traceWith f v = trace (f v) v


instance (Monad m) => Monoid (ServerPartT m a)
  where mempty = ServerPartT $ \rq -> noHandle
        mappend a b = ServerPartT $ \rq -> (unServerPartT a rq) `mappend` (unServerPartT b rq) 
instance (Monad m) => Monoid (WebT m a) where
  mempty = noHandle
  mappend a b = WebT $ do a' <- unWebT a
                          case a' of
                              NoHandle -> unWebT b
                              _        -> return a'

renderTemplateGroup :: (STGroup String) -> [(String, String)] -> String -> String
renderTemplateGroup gr attrs tmpl = 
   toString $
       maybe ( error $ "template not found: " ++ tmpl )
             ( setManyAttrib attrs )
             ( getStringTemplate tmpl gr )


----------------- reading data ----------------
readData :: RqData a -> Request -> Maybe a
readData rqDataReader rq = runReaderT rqDataReader $ (rqInputs rq,rqCookies rq)  
readDataDef :: b -> (a -> b) -> RqData a -> Request -> b
readDataDef def f rqDataReader rq = maybe def f . readData rqDataReader $ rq

dataReaderToWeb :: RqData a -> Request -> WebT IO (Maybe a)
dataReaderToWeb rqDataReader rq = return . readData rqDataReader $ rq
dataReaderToWebDef :: b -> (a -> b) -> RqData a -> Request -> WebT IO b
dataReaderToWebDef def f rqDataReader rq = return . readDataDef def f rqDataReader $ rq

dataReaderToSp :: RqData a -> ServerPartT IO (Maybe a)
dataReaderToSp rqDataReader = withRequest $ \rq -> dataReaderToWeb rqDataReader rq
dataReaderToSpDef :: b -> (a->b) -> RqData a -> ServerPartT IO b
dataReaderToSpDef def f rqDataReader = withRequest $ \rq -> dataReaderToWebDef def f rqDataReader rq

alltrue ps x = foldr g True ps
  where g p b = b && p x
nonetrue ps x = alltrue (map ( not . ) ps) x
  

-- Do something when the request has exactly one path segment left.
-- lastPathPartSp :: (Request -> String -> WebT IO Response) -> ServerPartT IO Response
lastPathPartSp f = ServerPartT $ \rq ->
  case rqPaths rq of
            [lastpart] -> f rq lastpart
            _ -> noHandle

ifFirstPathPartSp pathpart f = ServerPartT $ \rq ->
  case rqPaths rq of
            (x:xs) -> f rq pathpart
            _ -> noHandle