Routing.hs

module Bein.Web.Routing where

import System.Posix.Syslog
import Control.Monad
import Data.Monoid
import Bein.Web.Types
import Bein.Web.Commands
import Bein.Web.Pages.Index
import Bein.Web.Pages.Object
import Bein.Web.Pages.Settings
import Bein.Web.Pages.SignOut
import Bein.Web.Pages.New
import Happstack.Server hiding (dirs)
import Control.Monad.Trans
import System.FilePath
import Bein.Web.Pages.Login

breakAll :: Eq a => (a -> Bool) -> [a] -> [[a]]
breakAll _ [] = []
breakAll f l  = let (m,n) = break f l
                    q = breakAll f (safeTail n)
                in if m == [] then q else (m:q)
                  where safeTail [] = []
                        safeTail (_:b) = b

dirs :: (ServerMonad m, MonadPlus m) => String -> m a -> m a
dirs d r = let ds = breakAll ('/'==) d
           in foldr (\p q -> (dir p).q) id ds $ r

routing :: BeinServerPart Response
routing = do
  rq <- askRq
  liftIO $ syslog Notice $ "Request URI is " ++ rqUri rq
--  basePath <- lift $ configField http_base_path        
--  dirs basePath $ 
  mconcat [
    nullDir >> index,
    dir "login" $ login,
    dir "settings" $ settings,
    guardObject $ object,
    exactDir "signout" $ signOut,
    dir "new" $ newObject,
    staticData
    ]

staticData :: BeinServerPart Response  
staticData = mconcat [ staticFile "default.css" "text/css; charset=utf-8" ]
--                       staticFile "jquery.js" "text/javascript",
--                       staticFile "script.js" "text/javascript" ]
  where staticFile dirName contType = dir dirName $ do 
          d <- lift $ configField static_content_directory
          setHeaderM "Content-Type" contType
          fileServe [] (joinPath [d,dirName])