lucienne-0.0.2: Lucienne/Main.hs

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 ()