orchid-demo (empty) → 0.0.3

raw patch · 5 files changed

+200/−0 lines, 5 filesdep +Pipedep +basedep +mtlsetup-changedbinary-added

Dependencies added: Pipe, base, mtl, network, orchid, salvia, stm

Files

• LICENSE +28/−0
• Setup.lhs +6/−0
• data.zip binary
• orchid-demo.cabal +24/−0
• src/Demo.hs +142/−0

@@ -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.+

@@ -0,0 +1,6 @@+#! /usr/bin/env runhaskell++>import Distribution.Simple++>main = defaultMain+

binary file changed (absent → 70778 bytes)

@@ -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+

@@ -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    })) "<from-cabal>"+    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...]"+