happs-tutorial-0.1: 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.StringTemplate
import Data.Monoid

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

instance ToMessage (StringTemplate String) where
  toContentType _ = B.pack "text/html"
  toMessage = L.pack . toString  

{-  
exactdir :: Monad m => String -> [ServerPartT m a] -> ServerPartT m a
exactdir staticPath handlers
    = ServerPartT $ \rq -> if ( \rq' -> ( rqURL rq' == staticPath ) ) rq
                             then (\rq' -> unServerPartT (mconcat handlers) rq') rq
                             else mempty
-}
exactdir staticPath = spCatIf rqmatch
  where rqmatch rq = rqURL rq == staticPath

-- concat handlers if...
spCatIf rqmatch handlers = ServerPartT h
  where h rq = if rqmatch rq then unServerPartT (mconcat handlers) rq else mempty

traceTrue x = trace (show x) True


msgToWeb :: (Monad m, ToMessage a) => a -> WebT m Response
msgToWeb = return . toResponse

ioMsgToWeb :: (ToMessage a) => IO a -> WebT IO Response
ioMsgToWeb ios = liftIO $ do s <- ios
                             ( return . toResponse ) s

msgToSp :: (Monad m, ToMessage a) => a -> ServerPartT m Response
msgToSp = anyRequest . msgToWeb

ioMsgToSp :: (ToMessage a) => (IO a) -> ServerPartT IO Response
ioMsgToSp = anyRequest . ioMsgToWeb
traceIt x = trace (show x) x
traceMsg msg x = trace ( msg ++ (show x) ) x


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'

renderDef :: [(String,String)] -> String -> STGroup String -> StringTemplate String
renderDef attrs tmplname grp =
    maybe ( error $ "template not found: " ++ tmplname )
          ( setManyAttrib attrs )
          ( getStringTemplate tmplname grp )

-- withTemplateDir :: String -> (STGroup String -> String) -> IO String
withTemplateDir tdir f = return . f =<< unsafeVolatileDirectoryGroup tdir 1