module Main where import Control.Concurrent.STM import Control.Monad (when) import Control.Exception import System.Exit import System.IO import System.Environment import System.Console.GetOpt import System.Process.Pipe import Network.Socket (PortNumber, inet_addr) import Network.Protocol.Uri (jail) import Network.Salvia.Handlers.Default (hDefault) import Network.Salvia.Handlers.Login (readUserDatabase, UserPayload) import Network.Salvia.Handlers.Session (mkSessions, Sessions) import Network.Salvia.Advanced.ExtendedFileSystem (hExtendedFileSystem) import Network.Salvia.Httpd (defaultConfig, start, listenAddr, listenPort) import Network.Orchid.Wiki (hWiki) import Paths_orchid_demo ------------------------------------------------------------------------------- main :: IO () main = do argv <- getArgs prog <- getProgName conf <- parseOptions prog argv -- Extract data dir archive. when (extract conf) $ extractArchive (extractFrom conf) (extractTo conf) -- Run web server with wiki. run (asServer conf) (bindAddr conf) (bindPort conf) (dataDir conf) (userDB conf) -------- wiki server ---------------------------------------------------------- run :: Bool -> String -> PortNumber -> FilePath -> FilePath -> IO () run serve address port dir users = do -- Initialize global state. db <- readUserDatabase users ioconfig <- defaultConfig count <- atomically $ newTVar 0 sessions <- mkSessions :: IO (Sessions (UserPayload ())) addr <- inet_addr address -- Alter config and setup handler. let config = ioconfig { listenAddr = addr, listenPort = port } let myHandler = if serve then const $ hExtendedFileSystem dir else hWiki dir dir db -- Warn about serving user database. when (maybe False (const True) (jail dir users)) $ putStrLn "Warning: serving user database to the evil outside world." -- Print status messages and.. putStrLn $ concat ["Listening on ", address, ":", show (listenPort config), "."] putStrLn $ concat ["Using ", dir, " as wiki repository."] -- ..off we go! putStrLn "Server started." start config $ hDefault count sessions myHandler extractArchive :: FilePath -> FilePath -> IO () extractArchive from to = do putStrLn $ concat ["Extracting repository from ", from, " to ", to, "."] s <- pipeString [("unzip", [from, "-d", to])] "" evaluate $ length s return () -------- command line options parser ------------------------------------------ -- Application configuration type. data AppConfig = AppConfig { extract :: Bool , extractFrom :: String , extractTo :: String , dataDir :: String , userDB :: String , asServer :: Bool , bindAddr :: String , bindPort :: PortNumber } deriving Show -- Default application config. defaultAppConfig :: IO AppConfig defaultAppConfig = do dir <- getDataFileName "data.zip" return $ AppConfig { extract = False , extractFrom = dir , extractTo = "/tmp" , dataDir = "/tmp/data" , userDB = "/tmp/data/_user.db" , asServer = False , bindAddr = "0.0.0.0" , bindPort = 8080 } -- Command line argument declaration. options :: [OptDescr (AppConfig -> AppConfig)] options = let optExtract = NoArg (\ c -> c { extract = True }) optExtractFrom = OptArg (maybe id (\a c -> c { extractFrom = a })) "" optExtractTo = OptArg (maybe id (\a c -> c { extractTo = a })) "/tmp" optDataDir = OptArg (maybe id (\a c -> c { dataDir = a })) "/tmp/data" optUserDB = OptArg (maybe id (\a c -> c { userDB = a })) "/tmp/data/_user.db" optAsServer = NoArg (\ c -> c { asServer = True }) optBindAddr = OptArg (maybe id (\a c -> c { bindAddr = a })) "0.0.0.0" optBindPort = OptArg (maybe id (\a c -> c { bindPort = fromIntegral (read a :: Int) })) "8080" in [ Option [] ["extract"] optExtract "extract a demo repository from archive" , Option [] ["source-zip"] optExtractFrom "location of repository archive" , Option [] ["extract-to"] optExtractTo "location to extract demo archive to" , Option [] ["data-dir"] optDataDir "run demo with this repository" , Option [] ["user-db"] optUserDB "location of user database file" , Option [] ["as-server"] optAsServer "do not start wiki but serve directory" , Option [] ["address"] optBindAddr "address to listen on" , Option [] ["port"] optBindPort "port to bind to" ] -- Parser for the command line options. parseOptions :: String -> [String] -> IO AppConfig parseOptions prog argv = do def <- defaultAppConfig case getOpt Permute options argv of (o, _, []) -> return $ foldl (flip($)) def o (_, _, errs) -> putStrLn (concat errs ++ usageInfo header options) >> exitFailure where header = "Usage: " ++ prog ++ " [OPTION...]"