import Prelude hiding (catch) import Control.Monad (msum,when) import Control.Monad.Trans (lift) import Control.Exception (handle,AsyncException(UserInterrupt)) import Happstack.Server (Conf(port),simpleHTTP',nullConf,dir,dirs,path,nullDir,serveFile,asContentType,uriRest) import Database.MongoDB (runIOE,readHostPort,connect,close) import Paths_lucienne (getDataFileName) import Lucienne.Args (Args,applicationPort,getArgs,dbConnectionString) import Lucienne.ConnectionReader (Connection,ConnectionReader,runConnectionReader) import Lucienne.Model.User (newUser) import qualified Lucienne.Database as DB import Lucienne.Controller.BasicAuth (basicAuth) import Lucienne.Controller.AddNewUser (addNewUser,doAddNewUser) import Lucienne.Controller.AddNewFeed (addNewFeed,doAddNewFeed) import Lucienne.Controller.DeleteFeed (deleteFeed,doDeleteFeed) import Lucienne.Controller.Feed (feed,home) import Lucienne.Controller.FeedItem (feedItem,doDeleteFeedItem,doReadFeedItem,doChangeFeedItemState) import Lucienne.Controller.ChangePassword (changePassword,doChangePassword) import Lucienne.Controller.DeleteUser (deleteUser, doDeleteUser) import Lucienne.Controller.NotFound (notFound) import qualified Lucienne.Url as Url main :: IO () main = do args <- getArgs putStrLn $ "Connecting to database " ++ (dbConnectionString args) ++ " ..." connection <- runIOE $ connect $ readHostPort $ dbConnectionString args serverConfig <- return $ nullConf { port = applicationPort args } putStrLn $ "Running on port " ++ show (applicationPort args) ++ " ..." handle (\UserInterrupt -> closeConnection connection) $ do runConnectionReader connection addAdminAccountOnInit simpleHTTP' (runConnectionReader connection) serverConfig $ msum [ urlDir Url.addNewUser $ basicAuth addNewUser , urlDir Url.doAddNewUser $ basicAuth doAddNewUser , urlDir Url.addNewFeed $ basicAuth addNewFeed , urlDir Url.doAddNewFeed $ basicAuth doAddNewFeed , urlDir Url.deleteFeed $ path $ basicAuth . deleteFeed , urlDir Url.doDeleteFeed $ path $ basicAuth . doDeleteFeed , urlDir Url.feed $ path $ basicAuth . feed , urlDir Url.feedItem $ path $ basicAuth . feedItem , urlDirs Url.staticCss $ serveFile' "text/css" "static/css.css" , urlDirs Url.staticJs $ serveFile' "application/javascript" "static/js.js" , urlDir Url.doDeleteFeedItem $ path $ basicAuth . doDeleteFeedItem , urlDir Url.doReadFeedItem $ path $ basicAuth . doReadFeedItem , urlDir Url.doChangeFeedItemState $ basicAuth doChangeFeedItemState , urlDir Url.changePassword $ basicAuth changePassword , urlDir Url.doChangePassword $ basicAuth doChangePassword , urlDir Url.deleteUser $ basicAuth deleteUser , urlDir Url.doDeleteUser $ basicAuth doDeleteUser , nullDir >> basicAuth home , uriRest notFound ] where urlDir = dir . tail urlDirs = dirs . tail serveFile' ct filePath = do filePath' <- lift $ lift $ getDataFileName filePath serveFile (asContentType ct) filePath' closeConnection :: Connection -> IO () closeConnection c = do putStrLn "Closing connection ..." close c addAdminAccountOnInit :: ConnectionReader () addAdminAccountOnInit = do numUsers <- DB.countUsers when (0 == numUsers) $ do lift $ putStrLn "Creating admin account (admin:12345): please change password immediately ..." _ <- DB.addUser $ newUser "admin" "12345" True return ()