diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) Sebastiaan Visser 2008 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#! /usr/bin/env runhaskell + +>import Distribution.Simple + +>main = defaultMain + diff --git a/data.zip b/data.zip new file mode 100644 Binary files /dev/null and b/data.zip differ diff --git a/orchid-demo.cabal b/orchid-demo.cabal new file mode 100644 --- /dev/null +++ b/orchid-demo.cabal @@ -0,0 +1,24 @@ +Name: orchid-demo +Version: 0.0.3 +Description: Haskell Wiki Demo +Synopsis: Haskell Wiki Demo +Category: Network, Web +License: BSD3 +License-file: LICENSE +Author: Sebastiaan Visser +Maintainer: sfvisser@cs.uu.nl +Build-Type: Simple +Build-Depends: base, + network, + salvia ==0.0.4, + orchid ==0.0.6, + mtl ==1.1.0.2, + Pipe, + stm +Data-Files: data.zip + +Executable: orchid-demo +Main-is: Demo.hs +GHC-Options: -fglasgow-exts -threaded -Wall +HS-Source-Dirs: src + diff --git a/src/Demo.hs b/src/Demo.hs new file mode 100644 --- /dev/null +++ b/src/Demo.hs @@ -0,0 +1,142 @@ +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...]" +