bein 0.3.1 → 0.3.2

raw patch · 7 files changed

+60/−32 lines, 7 files

Files

• Bein/BeinCtl.hs +23/−2
• Bein/Web/Pages/Common.hs +8/−4
• Bein/Web/Pages/Index.hs +1/−3
• Bein/Web/Routing.hs +10/−5
• bein.cabal +3/−2
• sql/configuration.sql +14/−0
• sql/core_tables.sql +1/−16

@@ -16,10 +16,11 @@  module Main where +import Happstack.Crypto.SHA1 import Data.Maybe (fromJust) import System.FilePath import System.Exit ( exitSuccess, exitFailure )-import System.IO ( hPutStrLn, stderr )+import System.IO import System.Directory import System.Console.GetOpt import Database.HDBC@@ -94,6 +95,7 @@ parseCmd "reload" = reload parseCmd "deep-reload" = deepReload parseCmd "show-config" = showConfig+parseCmd "add-user" = addUser parseCmd cmd = \_ -> printHelpAndDie (Just ("Unknown command: " ++ cmd))  printCommands :: IO ()@@ -107,7 +109,8 @@      "    dump            - dump data in the database to tar archive file",       "    reload          - same as teardown followed by init",      "    deep-reload     - same as full-teardown followed by cold-init",-     "    show-config     - print the system configuration from the database"]+     "    show-config     - print the system configuration from the database",+     "    add-user        - create a new user on the system"]      coldInitialize :: State -> IO () coldInitialize st = do@@ -129,6 +132,7 @@   systemM $ "sudo -u postgres psql " ++ unlessVerbose "--quiet" ++ " --dbname bein --file "++ inPath "untrusted_functions.sql"   systemM $ "sudo -u bein psql " ++ unlessVerbose "--quiet" ++ " --dbname bein --file " ++ inPath "triggers.sql"   systemM $ "sudo -u bein psql " ++ unlessVerbose "--quiet" ++ " --dbname bein --file " ++ inPath "utility_functions.sql"+  systemM $ "sudo -u bein psql " ++ unlessVerbose "--quiet" ++ " --dbname bein --file " ++ inPath "configuration.sql"  fullTeardown :: State -> IO () fullTeardown st = do@@ -163,3 +167,20 @@ takeFirstM _ [] = fail $ "Nothing in list succeeds." takeFirstM f (c:cs) = f c >>= \r ->   if r then return c else takeFirstM f cs+                          +addUser :: State -> IO ()+addUser _ = do+  putStr "Enter name for new user: "+  hFlush stdout+  username <- getLine+  putStr "Enter password for new user: "+  hFlush stdout+  prevEchoState <- hGetEcho stdin+  hSetEcho stdin False+  password <- getLine+  hSetEcho stdin prevEchoState+  dbCommand (\conn -> do+    [[rId]] <- quickQuery' conn "select nextval('users_uid_seq')" []+    quickQuery' conn "insert into users (uid,name,default_gr,default_gw,default_wr,default_ww,auth_secret) values (?,?,true,true,true,true,?)" [rId, toSql username, toSql (sha1 password)]+    putStrLn $ "Created user with uid " ++ show (fromSql rId :: Int))+

@@ -80,15 +80,19 @@  objectFormTo :: String -> BeinServerPart (FormResponse a) -> Html -> BeinFormPart a Html objectFormTo url handler frm = do-  obj <- lift $ asksObject-  u <- lift $ fullUrl $ (show (objId obj) ++ "/" ++ case url of "" -> ""; '/':r -> r; r -> r)+--  obj <- lift $ asksObject+--  u <- lift $ fullUrl $ (show (objId obj) ++ "/" ++ case url of "" -> ""; '/':r -> r; r -> r)   tell [(url,handler)]-  formM <! [method "post", action u] $ frm+  currentUrl <- liftM rqUri $ lift askRq+  baseUrl <- lift $ lift $ configField http_base_path+  formM <! [method "post", action (joinURL baseUrl (joinURL currentUrl url))] $ frm  formTo :: String -> BeinServerPart (FormResponse a) -> Html -> BeinFormPart a Html formTo url handler frm = do+  currentUrl <- liftM rqUri $ lift askRq+  baseUrl <- lift $ lift $ configField http_base_path   tell [(url, handler)]-  formM <! [method "post", action url] $ frm+  formM <! [method "post", action (joinURL baseUrl (joinURL currentUrl url))] $ frm  multipartFormTo :: String -> BeinServerPart (FormResponse a) -> Html -> BeinFormPart a Html multipartFormTo url handler frm = do

@@ -39,14 +39,12 @@ leftPane :: BeinObject -> BeinServerPart Html leftPane obj = do   displayUrl <- fullUrl ("/" ++ show (objId obj))-  editUrl <- fullUrl ("/" ++ show (objId obj) ++ "/edit")   let h = objHeader obj   thedivM <! [theclass "left"] =<<: [      paragraphM <! [theclass "title"] =<< anchorM <! [href displayUrl] << objectTag obj,     paragraphM << (userName (owner h) ++ "/" ++ groupName (group h) ++ " " ++ formatPermissions (gr h) (gw h) (wr h) (ww h)),     paragraphM << ("Last modified " ++ formatTime defaultTimeLocale "%F %R" (lastModified h)),-    paragraphM << ("Created " ++ formatTime defaultTimeLocale "%F %R" (created h)), -    paragraphM =<< anchorM <! [href editUrl] << "Edit" ]+    paragraphM << ("Created " ++ formatTime defaultTimeLocale "%F %R" (created h)) ]          rightPane :: BeinObject -> BeinServerPart Html rightPane obj = thedivM <! [theclass "right"] =<<: [

@@ -1,5 +1,6 @@ module Bein.Web.Routing where +import System.Posix.Syslog import Control.Monad import Data.Monoid import Bein.Web.Types@@ -14,10 +15,11 @@ import System.FilePath import Bein.Web.Pages.Login -breakAll :: (a -> Bool) -> [a] -> [[a]]+breakAll :: Eq a => (a -> Bool) -> [a] -> [[a]] breakAll _ [] = []-breakAll f l  = let (a,b) = break f l-                in a : breakAll f (safeTail b)+breakAll f l  = let (m,n) = break f l+                    q = breakAll f (safeTail n)+                in if m == [] then q else (m:q)                   where safeTail [] = []                         safeTail (_:b) = b @@ -27,8 +29,11 @@  routing :: BeinServerPart Response routing = do-  basePath <- lift $ configField http_base_path        -  dirs basePath $ mconcat [+  rq <- askRq+  liftIO $ syslog Notice $ "Request URI is " ++ rqUri rq+--  basePath <- lift $ configField http_base_path        +--  dirs basePath $ +  mconcat [     nullDir >> index,     dir "login" $ login,     dir "settings" $ settings,

@@ -1,5 +1,5 @@ name:                bein-version:             0.3.1+version:             0.3.2 synopsis:            Bein is a provenance and workflow management system for bioinformatics. description:         To avoid having thousands of files produced in a random way from a bunch of scripts, as is typically the case for a bioinformaticist, Bein keeps track of scripts, and their executions on various inputs.  It provides a web front end, and will integrate with LSF clusters. category:            Application@@ -13,7 +13,8 @@  Executable beinctl   Main-is:           Bein/BeinCtl.hs-  Build-Depends:     base >= 3 && < 5, HDBC, HDBC-postgresql, process+  Build-Depends:     base >= 3 && < 5, HDBC, HDBC-postgresql, process, +                     happstack-util   Ghc-Options:       -Wall -threaded -fno-warn-unused-do-bind   Other-Modules:     Bein.Types, Bein.Configuration, Bein.ShellScripting   Hs-Source-Dirs:    .

@@ -0,0 +1,14 @@+insert into configuration (key,value) values ('file_repository','/tmp/bein_files');+insert into configuration (key,value) values ('scratch_directory','/tmp/bein_scratch');+insert into configuration (key,value) values ('static_content_directory','/home/ross/bein/static');+insert into configuration (key,value) values ('perl_executable','/usr/bin/perl');+insert into configuration (key,value) values ('r_executable','/usr/bin/R');+insert into configuration (key,value) values ('max_executions',1000);+insert into configuration (key,value) values ('minion_command','beinminion');+insert into configuration (key,value) values ('daemon_port','/tmp/.s.BEIND');+insert into configuration (key,value) values ('minion_port','.s.MINION');+insert into configuration (key,value) values ('http_port',8082);+insert into configuration (key,value) values ('http_base_url','');+insert into configuration (key,value) values ('http_base_path','');+insert into configuration (key,value) values ('authentication','None');+insert into configuration (key,value) values ('template_path','/home/ross/bein/templates');

@@ -28,7 +28,7 @@        enum ('password','host','nologin');  create table users (-       uid integer primary key,+       uid serial primary key,        name varchar unique not null,        default_gr boolean not null,        default_gw boolean not null,@@ -396,21 +396,6 @@        key configuration_key primary key,        value varchar );--insert into configuration (key,value) values ('file_repository','/tmp/bein_files');-insert into configuration (key,value) values ('scratch_directory','/tmp/bein_scratch');-insert into configuration (key,value) values ('static_content_directory','/home/ross/bein/static');-insert into configuration (key,value) values ('perl_executable','/usr/bin/perl');-insert into configuration (key,value) values ('r_executable','/usr/bin/R');-insert into configuration (key,value) values ('max_executions',1000);-insert into configuration (key,value) values ('minion_command','beinminion');-insert into configuration (key,value) values ('daemon_port','/tmp/.s.BEIND');-insert into configuration (key,value) values ('minion_port','.s.MINION');-insert into configuration (key,value) values ('http_port',8082);-insert into configuration (key,value) values ('http_base_url','');-insert into configuration (key,value) values ('http_base_path','');-insert into configuration (key,value) values ('authentication','None');-insert into configuration (key,value) values ('template_path','/home/ross/bein/templates');  create or replace function delete_fails() returns trigger as $$ begin