Routing.hs

module Bein.Web.Routing where

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 :: (a -> Bool) -> [a] -> [[a]]
breakAll _ [] = []
breakAll f l  = let (a,b) = break f l
                in a : breakAll f (safeTail b)
                  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
  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])