{-# LANGUAGE CPP, RankNTypes, RecordWildCards, OverloadedStrings #-} module Main where import Control.Monad.State (evalStateT, get, modify) import Clckwrks import Clckwrks.Admin.Template (defaultAdminMenu) import Clckwrks.Server import Clckwrks.Media import Clckwrks.Media.PreProcess (mediaCmd) import qualified Data.ByteString.Char8 as C import Data.List (intercalate) import qualified Data.Map as Map import Data.Monoid (mappend) import Data.Text (Text) import Data.Text.Lazy.Builder (Builder) import qualified Data.Text as Text import qualified Paths_clckwrks as Clckwrks #ifdef CABAL import qualified Paths_clckwrks_theme_happstack as Theme #endif import qualified Paths_clckwrks_plugin_media as Media import System.Console.GetOpt import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) import System.FilePath (()) import URL import Web.Routes.Happstack () import qualified Theme.Blog as Blog #ifdef PLUGINS import Control.Monad.State (get) import System.Plugins.Auto (PluginHandle, PluginConf(..), defaultPluginConf, initPlugins, withMonadIOFile) #else import PageMapper #endif ------------------------------------------------------------------------------ -- Command line options ------------------------------------------------------------------------------ -- | command-line Flags data Flag = ModifyConfig (forall url. ClckwrksConfig url -> ClckwrksConfig url) | Help | Version -- | Flag selectors isHelp, isVersion :: Flag -> Bool isHelp flag = case flag of Help -> True; _ -> False isVersion flag = case flag of Version -> True; _ -> False -- | Command line options. clckwrksOpts :: [OptDescr Flag] clckwrksOpts = [ -- Option [] ["version"] (NoArg Version) "Display version information" Option [] ["help"] (NoArg Help) "Display this help message" , Option [] ["http-port"] (ReqArg setPort "port") "Port to bind http server" , Option [] ["hostname"] (ReqArg setHostname "hostname") "Server hostename" , Option [] ["jquery-path"] (ReqArg setJQueryPath "path") "path to jquery directory" , Option [] ["jqueryui-path"] (ReqArg setJQueryPath "path") "path to jqueryui directory" , Option [] ["jstree-path"] (ReqArg setJSTreePath "path") "path to jstree directory" , Option [] ["json2-path"] (ReqArg setJSON2Path "path") "path to json2 directory" , Option [] ["theme-path"] (ReqArg setThemeDir "path") "path to theme directory" ] where setPort str = ModifyConfig $ \c -> c { clckPort = read str } setHostname str = ModifyConfig $ \c -> c { clckHostname = str } setJQueryPath str = ModifyConfig $ \c -> c { clckJQueryPath = str } setJQueryUIPath str = ModifyConfig $ \c -> c { clckJQueryUIPath = str } setJSTreePath str = ModifyConfig $ \c -> c { clckJSTreePath = str } setJSON2Path str = ModifyConfig $ \c -> c { clckJSON2Path = str } setThemeDir str = ModifyConfig $ \c -> c { clckThemeDir = str } -- | Parse the command line arguments into a list of flags. Exits with usage -- message, in case of failure. parseArgs :: [OptDescr Flag] -> [String] -> IO (ClckwrksConfig url -> ClckwrksConfig url) parseArgs opts args = case getOpt Permute opts args of (flags,_,[]) -> if any isHelp flags then do putStr (helpMessage opts) exitSuccess else do return $ foldr (.) id [f | (ModifyConfig f) <- flags ] (_,_,errs) -> do putStr ("Failure while parsing command line:\n"++unlines errs) putStr (helpMessage opts) exitFailure -- | A simple usage message listing all flags possible. helpMessage :: [OptDescr Flag] -> String helpMessage opts = usageInfo header opts where header = "Usage: clckwrks [OPTION...]" clckwrksConfig :: IO (ClckwrksConfig SiteURL) clckwrksConfig = do clckDir <- Clckwrks.getDataDir #ifdef CABAL themeDir <- Theme.getDataDir #else let themeDir = "../clckwrks-theme-happstack/" #endif mediaDir <- Media.getDataDir return $ ClckwrksConfig { clckHostname = "localhost" , clckPort = 8000 , clckURL = C , clckJQueryPath = "/usr/share/javascript/jquery/" , clckJQueryUIPath = "/usr/share/javascript/jquery-ui/" , clckJSTreePath = clckDir "jstree" , clckJSON2Path = clckDir "json2" , clckThemeDir = themeDir , clckPluginDir = [("media", mediaDir)] , clckStaticDir = clckDir "static" #ifdef PLUGINS , clckPageHandler = undefined #else , clckPageHandler = staticPageHandler #endif , clckBlogHandler = staticBlogHandler } getClckwrksConfig :: [OptDescr Flag] -> IO (ClckwrksConfig SiteURL) getClckwrksConfig opts = do args <- getArgs f <- parseArgs opts args cc <- clckwrksConfig return (f cc) ------------------------------------------------------------------------------ -- SitePlus ------------------------------------------------------------------------------ data SitePlus url a = SitePlus { siteSite :: Site url a , siteDomain :: Text , sitePort :: Int , siteAppRoot :: Text , sitePrefix :: Text , siteShowURL :: url -> [(Text, Maybe Text)] -> Text , siteParsePathInfo :: C.ByteString -> Either String url } instance Functor (SitePlus url) where fmap f sitePlus = sitePlus { siteSite = fmap f (siteSite sitePlus) } mkSitePlus :: Text -> Int -> Text -> Site url a -> SitePlus url a mkSitePlus domain port approot site = SitePlus { siteSite = site , siteDomain = domain , sitePort = port , siteAppRoot = approot , sitePrefix = prefix , siteShowURL = showFn , siteParsePathInfo = parsePathSegments site . decodePathInfo } where showFn url qs = let (pieces, qs') = formatPathSegments site url in approot `mappend` (encodePathInfo pieces (qs ++ qs')) prefix = Text.concat $ [ Text.pack "http://" , domain ] ++ (if port == 80 then [] else [Text.pack ":", Text.pack $ show port] ) ++ [ approot ] runSitePlus_ :: (Happstack m) => SitePlus url (m a) -> m (Either String a) runSitePlus_ sitePlus = dirs (Text.unpack (siteAppRoot sitePlus)) $ do rq <- askRq let r = runSite (sitePrefix sitePlus) (siteSite sitePlus) (map Text.pack $ rqPaths rq) case r of (Left parseError) -> return (Left parseError) (Right sp) -> Right <$> (localRq (const $ rq { rqPaths = [] }) sp) where escapeSlash :: String -> String escapeSlash [] = [] escapeSlash ('/':cs) = "%2F" ++ escapeSlash cs escapeSlash (c:cs) = c : escapeSlash cs runSitePlus :: (Happstack m) => SitePlus url (m a) -> m a runSitePlus sitePlus = do r <- runSitePlus_ sitePlus case r of (Left _) -> mzero (Right a) -> return a ------------------------------------------------------------------------------ -- Plugins ------------------------------------------------------------------------------ initPlugins :: ClckT SiteURL IO () initPlugins = do showFn <- askRouteFn let mediaCmd' :: forall url m. (Monad m) => (Text -> ClckT url m Builder) mediaCmd' = mediaCmd (\u p -> showFn (M u) p) addPreProcessor "media" mediaCmd' nestURL M $ addMediaAdminMenu dm <- nestURL C $ defaultAdminMenu mapM_ addAdminMenu dm ------------------------------------------------------------------------------ -- Server ------------------------------------------------------------------------------ {- The Problem: withClckwrks, withMediaConfig, etc, allocate resources and create State types which are needed in order to run clcwrks and other plugins. but, we have further plugin initialization that needs to happen, like registering PreProcessor callbacks. And, those extra initializations might need to know how to create URLs. but, we don't know how to show those urls until we call mkSitePlus -- which requires us to pass in mediaConf. -} clckwrks :: ClckwrksConfig SiteURL -> IO () clckwrks cc' = do args <- getArgs let cc = case args of [] -> cc' (h:_) -> cc' { clckHostname = h } withClckwrks cc $ \clckState -> withMediaConfig Nothing "_uploads" $ \mediaConf -> let -- site = mkSite (clckPageHandler cc) clckState mediaConf site = mkSite2 cc mediaConf sitePlus = mkSitePlus (Text.pack $ clckHostname cc) (clckPort cc) Text.empty site in do clckState' <- execClckT (siteShowURL sitePlus) clckState $ initPlugins let sitePlus' = fmap (evalClckT (siteShowURL sitePlus) clckState') sitePlus simpleHTTP (nullConf { port = clckPort cc }) (route cc sitePlus') {- -- clckwrks_ :: ClckwrksConfig SiteURL -> (IO (Site SiteURL (ClckT SiteURL (ServerPartT IO) Response) -> IO ())) -> IO () clckwrks_ cc' f = do args <- getArgs let cc = case args of [] -> cc' (h:_) -> cc' { clckHostname = h } withClckwrks cc $ \clckState -> doMedia $ \site -> -- withMediaConfig Nothing "_uploads" $ \mediaConf -> let -- site = mkSite (clckPageHandler cc) clckState mediaConf -- site = mkSite2 cc mediaConf sitePlus = mkSitePlus (Text.pack $ clckHostname cc) (clckPort cc) Text.empty site in do clckState' <- execClckT (siteShowURL sitePlus) clckState $ initPlugins let sitePlus' = fmap (evalClckT (siteShowURL sitePlus) clckState') sitePlus simpleHTTP (nullConf { port = clckPort cc }) (route cc sitePlus') where doMedia cont = withMediaConfig Nothing "_uplod" $ \mediaConfig -> let site = mkSite2 cc mediaConf in cont site -} route :: Happstack m => ClckwrksConfig SiteURL -> SitePlus SiteURL (m Response) -> m Response route cc sitePlus = do decodeBody (defaultBodyPolicy "/tmp/" (10 * 10^6) (1 * 10^6) (1 * 10^6)) msum $ [ jsHandlers cc , dir "favicon.ico" $ notFound (toResponse ()) , dir "static" $ serveDirectory DisableBrowsing [] (clckStaticDir cc) , dir "login" $ seeOther ((siteShowURL sitePlus) (C $ Auth $ AuthURL A_Login) []) (toResponse ()) , dir "admin" $ seeOther ((siteShowURL sitePlus) (C $ Admin Console) []) (toResponse ()) , runSitePlus sitePlus ] {- we can't register the pp callbacks instead the nestURL because then the only callbacks will only be available when that route is active. it is 'tricky' to register the callbacks outside, because the callbacks might require information that is only available 'inside' the monad. But, of course, that is silly now that we think about it. Because that monad is only available when processing the route. But when doing the pp, that route may not be the one we are doing. So, the reason it is hard to get the monad into the callback is because we shouldn't. The pp has to assume that the route being processed is not one of those. Well, that is not actually a problem. The monad is really an environment in which a computation can run. And we can create that environment multiple ways. The issue with the MediaT monad is that it includes the MediaURL. And so to work with that, we need to specify how to turn a MediaURL into a SiteURL. That is something we normally do in routeSite via 'nestURL M'. But that means we have to repeat ourselves. we could have a function like withMediaT to contruct a temporary MediaT monad to be used when registering the callback. Though there is a danger there, because some of the information use to register the callback might become stale. p In theory, we would like to do some stuff in the ClckT monad before start listening to incoming requests. However, to run the ClckT monad we need to provide the show function. Normally that is done transparently via implSite / site / etc. Though it seems the information we need comes from Site not implSite. -} routeSite :: ClckwrksConfig u -> MediaConfig -> SiteURL -> Clck SiteURL Response routeSite cc mediaConfig url = do case url of (C clckURL) -> nestURL C $ routeClck cc clckURL (M mediaURL) -> do showFn <- askRouteFn -- FIXME: it is a bit silly that we wait this long to set the mediaClckURL -- would be better to do it before we forkIO on simpleHTTP nestURL M $ runMediaT (mediaConfig { mediaClckURL = (showFn . C) }) $ routeMedia mediaURL {- mkSite :: ClckwrksConfig u -> ClckState -> MediaConfig -> Site SiteURL (ServerPart Response) mkSite cc clckState media = setDefault (C $ ViewPage $ PageId 1) $ mkSitePI route' where route' f u = evalStateT (unRouteT (unClckT $ routeSite cc media u) f) clckState -} -- FIXME: something seems weird here.. we do not use the 'f' in route' mkSite2 :: ClckwrksConfig u -> MediaConfig -> Site SiteURL (ClckT SiteURL (ServerPartT IO) Response) mkSite2 cc mediaConfig = setDefault (C $ ViewPage $ PageId 1) $ mkSitePI route' where route' :: (SiteURL -> [(Text.Text, Maybe Text.Text)] -> Text.Text) -> SiteURL -> ClckT SiteURL (ServerPartT IO) Response route' f url = routeSite cc mediaConfig url #ifdef PLUGINS main :: IO () main = do ph <- initPlugins putStrLn "Dynamic Server Started." cc <- getClckwrksConfig clckwrksOpts clckwrks (cc { clckPageHandler = dynamicPageHandler ph }) dynamicPageHandler :: PluginHandle -> Clck ClckURL Response dynamicPageHandler ph = do fp <- themePath <$> get withMonadIOFile "PageMapper.hs" "pageMapper" ph (\pc -> pc { pcGHCArgs = [ "-i" ++ fp] }) notLoaded page where page :: [String] -> XMLGenT (Clck url) XML -> Clck url Response page _errs (XMLGenT part) = toResponse <$> part notLoaded errs = internalServerError $ toResponse $ unlines errs #else main :: IO () main = do putStrLn "Static Server Started." cc <- getClckwrksConfig clckwrksOpts clckwrks cc staticPageHandler :: Clck ClckURL Response staticPageHandler = toResponse <$> unXMLGenT pageMapper #endif staticBlogHandler :: Clck ClckURL Response staticBlogHandler = toResponse <$> unXMLGenT Blog.page