sproxy-web 0.3.1 → 0.4
raw patch · 11 files changed
+604/−412 lines, 11 filesdep +docoptdep +interpolatedstring-perl6dep +networkdep −hflags
Dependencies added: docopt, interpolatedstring-perl6, network, unix
Dependencies removed: hflags
Files
- ChangeLog.md +6/−0
- README.md +9/−7
- example.config +0/−4
- sproxy-web.cabal +24/−21
- src/Application.hs +375/−0
- src/Config.hs +0/−44
- src/DB.hs +4/−14
- src/Handlers.hs +0/−319
- src/Main.hs +52/−3
- src/Server.hs +79/−0
- src/Views/Search.hs +55/−0
ChangeLog.md view
@@ -1,3 +1,9 @@+0.4+===++ * Listen on UNIX socket (default), TCP allowed on localhost only.+ * Use command-line options instead of configuration file+ 0.3.1 =====
README.md view
@@ -22,15 +22,17 @@ ===== Type `sproxy-web --help` to see usage summary: - sproxy-web - Web interface to the sproxy permissions database+ Usage:+ sproxy-web [options] - -h --help, --usage, --version Display help and version information.- --undefok Whether to fail on unrecognized command line options.- -c STRING --config=STRING config file (default: sproxy-web.config, from module: Config)+ Options: + -c, --connstr=CONNSTR PostgreSQL connection string [default: dbname=sproxy]+ -d, --datadir=DIR Data directory including static files [default: <cabal data dir>] -The config file must have the following simplistic structure.+ -s, --socket=SOCK Listen on this UNIX socket [default: /tmp/sproxy-web.sock]+ -p, --port=PORT Instead of UNIX socket, listen on this TCP port (localhost) - db_connection_string = "host=127.0.0.1 port=4534 user=alp dbname=alp password=blah"- port = 8003+ -h, --help Show this message+
− example.config
@@ -1,4 +0,0 @@--db_connection_string = "hostaddr=127.0.0.1 user=alp dbname=alp"--port = 8001
sproxy-web.cabal view
@@ -1,5 +1,5 @@ name: sproxy-web-version: 0.3.1+version: 0.4 synopsis: Web interface to sproxy database description: Web frontend for managing sproxy.@@ -11,7 +11,7 @@ copyright: 2014-2016, Zalora South East Asia Pte. Ltd category: Web build-type: Simple-extra-source-files: README.md ChangeLog.md example.config+extra-source-files: README.md ChangeLog.md cabal-version: >= 1.20 data-files: static/css/*.css,@@ -36,11 +36,10 @@ main-is: Main.hs hs-source-dirs: src other-modules:- Config+ Application DB Entities- Handlers- Paths_sproxy_web+ Server SproxyError Views.Common Views.DomainList@@ -50,25 +49,29 @@ Views.Homepage Views.MemberList Views.PrivilegeRules+ Views.Search build-depends:- base >= 4.8 && < 5- , aeson >= 0.6- , blaze-html >= 0.7- , blaze-markup >= 0.6- , bytestring >= 0.10- , configurator >= 0.2+ base >= 4.8 && < 5+ , aeson >= 0.6+ , blaze-html >= 0.7+ , blaze-markup >= 0.6+ , bytestring >= 0.10+ , configurator >= 0.2 , data-default-class , directory+ , docopt >= 0.7 , filepath- , hflags >= 0.4- , http-types >= 0.8- , mtl >= 2.1- , postgresql-simple >= 0.4- , resource-pool >= 0.2- , scotty >= 0.10- , text >= 0.11+ , http-types >= 0.8+ , interpolatedstring-perl6+ , mtl >= 2.1+ , network >= 2.6+ , postgresql-simple >= 0.4+ , resource-pool >= 0.2+ , scotty >= 0.10+ , text >= 0.11+ , unix >= 2.7 , wai- , wai-extra >= 2.0- , wai-middleware-static >= 0.4- , warp >= 3.2+ , wai-extra >= 2.0+ , wai-middleware-static >= 0.4+ , warp >= 3.2
+ src/Application.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Application (+ app+) where++import Control.Exception+import Control.Monad (when)+import Data.Default.Class+import Data.Int (Int64)+import Data.Monoid+import Data.Pool (Pool)+import Data.Text.Lazy as Text+import Database.PostgreSQL.Simple (Connection)+import Network.HTTP.Types.Status+import Network.Wai (Application, Middleware)+import Network.Wai.Middleware.RequestLogger+import Network.Wai.Middleware.Static+import System.IO+import Text.Blaze.Html.Renderer.Text (renderHtml)+import Text.Blaze.Html5 (Html)+import Views.DomainList (domainListT)+import Views.DomainPrivileges (domainPrivilegesT)+import Views.ErrorPage (errorPageT)+import Views.GroupList (groupListT)+import Views.Homepage (homepageT)+import Views.MemberList (memberListT)+import Views.PrivilegeRules (privilegeRulesT)+import Views.Search (searchResultsT)+import Web.Scotty.Trans++import SproxyError+import DB+import Entities++app :: Pool Connection -> FilePath -> IO Application+app c p = do+ logger <- mkRequestLogger def{ destination = Handle stderr }+ scottyAppT id (sproxyWeb c p logger)++sproxyWeb :: Pool Connection -> FilePath -> Middleware -> ScottyT SproxyError IO ()+sproxyWeb pool staticDirectory logger = do+ middleware logger++ middleware (staticPolicy (hasPrefix "static" >-> addBase staticDirectory))++ -- error page for uncaught exceptions+ defaultHandler handleEx++ get "/" $ homepage pool++ post "/search" $ searchUserH pool+ post "/delete-user" $ deleteUserH pool+ post "/rename-user" $ renameUserH pool++ -- groups+ get "/groups" $ groupList pool -- this is the group listing page+ get "/groups.json" $ jsonGroupList pool -- json endpoint returning an array of group names+ post "/groups" $ jsonUpdateGroup pool -- endpoint where we POST requests for modifications of groups++ -- group+ get "/group/:group/members" $ memberList pool -- list of members for a group+ post "/group/:group/members" $ jsonPostMembers pool -- endpoint for POSTing updates to the member list++ -- domains+ get "/domains" $ domainList pool -- list of domains handled by sproxy+ post "/domains" $ jsonUpdateDomain pool -- endpoint for POSTing updates++ -- privileges for a given domain+ get "/domain/:domain/privileges" $ domainPrivileges pool -- listing of privileges available on a domain+ get "/domain/:domain/privileges.json" $ jsonDomainPrivileges pool -- json endpoint, array of privilege names+ post "/domain/:domain/privileges" $ jsonPostDomainPrivileges pool -- endpoint for POSTing updates++ -- rules for a given privilege on a given domain+ get "/domain/:domain/privilege/:privilege/rules" $ privilegeRules pool -- listing of paths/methods associated to a privilege+ post "/domain/:domain/privilege/:privilege/rules" $ jsonPostRule pool -- endpoint for POSTing updates about these++ -- add/remove group privileges+ post "/domain/:domain/group_privileges" $ handleGPs pool -- endpoint for POSTing privilege granting/removal for groups+++blaze :: Html -> ActionT SproxyError IO ()+blaze = Web.Scotty.Trans.html . renderHtml++handleEx :: SproxyError -> ActionT SproxyError IO ()+handleEx = errorPage++errorPage :: SproxyError -> ActionT SproxyError IO ()+errorPage err = blaze (errorPageT err)++homepage :: Pool Connection -> ActionT SproxyError IO ()+homepage _ = blaze homepageT++------------------------------------------+-- handlers related to the group list page+------------------------------------------++-- POST /groups+jsonUpdateGroup :: Pool Connection -> ActionT SproxyError IO ()+jsonUpdateGroup pool = do+ (operation :: Text) <- param "operation"+ (t, n) <- case operation of+ "add" -> do+ g <- param "group"+ checked pool (addGroup g)++ "del" -> do+ g <- param "group"+ checked pool (removeGroup g)++ "upd" -> do+ old <- param "old"+ new <- param "new"+ checked pool (updateGroup old new)++ _ -> status badRequest400 >> return ("incorrect operation", (-1))++ outputFor t n++-- GET /groups+groupList :: Pool Connection -> ActionT SproxyError IO ()+groupList pool = do+ groups <- Prelude.map Prelude.head `fmap` withDB pool getGroups+ blaze (groupListT groups)++-- GET /groups.json+jsonGroupList :: Pool Connection -> ActionT SproxyError IO ()+jsonGroupList pool = do+ groups <- Prelude.map Prelude.head `fmap` withDB pool getGroups++ json groups++---------------------------------------------------+-- handlers related to the group members list page+---------------------------------------------------++-- GET /group/:group+memberList :: Pool Connection -> ActionT SproxyError IO ()+memberList pool = do+ groupName <- param "group"+ members <- Prelude.map Prelude.head `fmap` withDB pool (getMembersFor groupName)+ blaze (memberListT members groupName)++-- POST /group/:group/members+jsonPostMembers :: Pool Connection -> ActionT SproxyError IO ()+jsonPostMembers pool = do+ groupName <- param "group"++ (operation :: Text) <- param "operation"++ (t, n) <- case operation of+ "add" -> do+ m <- param "member"+ checked pool (addMemberTo m groupName)++ "del" -> do+ m <- param "member"+ checked pool (removeMemberOf m groupName)++ "upd" -> do+ old <- param "old"+ new <- param "new"+ checked pool (updateMemberOf old new groupName)++ _ -> status badRequest400 >> return ("incorrect operation", (-1))++ outputFor t n++--------------------------------------+-- handlers related to the domain list+--------------------------------------++-- GET /domains+domainList :: Pool Connection -> ActionT SproxyError IO ()+domainList pool = do+ domains <- Prelude.map Prelude.head `fmap` withDB pool getDomains+ blaze (domainListT domains)++-- POST /domains+jsonUpdateDomain :: Pool Connection -> ActionT SproxyError IO ()+jsonUpdateDomain pool = do+ (operation :: Text) <- param "operation"+ (t, n) <- case operation of+ "add" -> do+ d <- param "domain"+ checked pool (addDomain d)++ "del" -> do+ d <- param "domain"+ checked pool (removeDomain d)++ "upd" -> do+ old <- param "old"+ new <- param "new"+ checked pool (updateDomain old new)++ _ -> status badRequest400 >> return ("incorrect operation", (-1))++ outputFor t n++-------------------------------------------------------------------------+-- handlers related to the list of possible privileges for a given domain+-------------------------------------------------------------------------++-- GET /domain/:domain/privileges+domainPrivileges :: Pool Connection -> ActionT SproxyError IO ()+domainPrivileges pool = do+ domain <- param "domain"+ privileges <- Prelude.map Prelude.head `fmap` withDB pool (getDomainPrivileges domain)+ groups <- Prelude.map Prelude.head `fmap` withDB pool getGroups+ groupPrivs <- withDB pool (getGroupPrivsFor domain)++ blaze (domainPrivilegesT domain privileges groups groupPrivs)++-- GET /domain/:domain/privileges.json+jsonDomainPrivileges :: Pool Connection -> ActionT SproxyError IO ()+jsonDomainPrivileges pool = do+ domain <- param "domain"+ privileges <- Prelude.map Prelude.head `fmap` withDB pool (getDomainPrivileges domain)++ json privileges++-- POST /domain/:domain/group_privileges+handleGPs :: Pool Connection -> ActionT SproxyError IO ()+handleGPs pool = do+ domain <- param "domain"++ (operation :: Text) <- param "operation"++ (t, n) <- case operation of+ "add" -> do+ grp <- param "group"+ priv <- param "privilege"+ checked pool (addGPFor domain grp priv)++ "del" -> do+ grp <- param "group"+ priv <- param "privilege"+ checked pool (deleteGPOf domain grp priv)++ _ -> status badRequest400 >> return ("incorrect operation", (-1))++ outputFor t n++-- POST /domain/:domain/privileges+jsonPostDomainPrivileges :: Pool Connection -> ActionT SproxyError IO ()+jsonPostDomainPrivileges pool = do+ domain <- param "domain"++ (operation :: Text) <- param "operation"++ (t, n) <- case operation of+ "add" -> do+ p <- param "privilege"+ checked pool (addPrivilegeToDomain p domain)++ "del" -> do+ p <- param "privilege"+ checked pool (removePrivilegeOfDomain p domain)++ "upd" -> do+ old <- param "old"+ new <- param "new"+ checked pool (updatePrivilegeOfDomain old new domain)++ _ -> status badRequest400 >> return ("incorrect operation", (-1))++ outputFor t n++-------------------------------------------------------------------------------+-- handlers related to the rules associated to a given privilege on some domain+-------------------------------------------------------------------------------++-- GET /domain/:domain/privilege/:privilege/rules+privilegeRules :: Pool Connection -> ActionT SproxyError IO ()+privilegeRules pool = do+ -- TODO: check that the domain and privilege exist+ domain <- param "domain"+ privilege <- param "privilege"+ rules <- withDB pool (getRules domain privilege)++ blaze (privilegeRulesT domain privilege rules)++-- POST /domain/:domain/privilege/:privilege/rules+jsonPostRule :: Pool Connection -> ActionT SproxyError IO ()+jsonPostRule pool = do+ -- TODO: check that the domain and privilege exist+ domain <- param "domain"+ privilege <- param "privilege"+ operation <- param "operation"+ case operation :: Text of+ "add" -> addRule domain privilege+ "del" -> delRule domain privilege+ "upd" -> updRule domain privilege+ _ -> status badRequest400 >> text "bad operation"++ where+ addRule domain privilege = do+ path <- param "path"+ method <- param "method"++ (t, n) <- checked pool+ (addRuleToPrivilege domain privilege path method)++ outputFor t n++ delRule domain privilege = do+ path <- param "path"+ method <- param "method"++ (t, n) <- checked pool+ (deleteRuleFromPrivilege domain privilege path method)++ outputFor t n++ updRule domain privilege = do+ what <- param "what"++ when (what /= "path" && what /= "method") $ text "invalid 'what'"++ let updFunc = if what == "path" then updatePathFor else updateMethodFor++ old <- param ("old" <> what)+ new <- param ("new" <> what)+ otherField <- param $ if what == "path" then "method" else "path"++ (t, n) <- checked pool+ (updFunc domain privilege new old otherField)++ outputFor t n++-- | POST /search, search string in "search_query"+searchUserH :: Pool Connection -> ActionT SproxyError IO ()+searchUserH pool = do+ searchStr <- param "search_query"++ matchingEmails <- withDB pool (searchUser searchStr)++ blaze (searchResultsT searchStr matchingEmails)++-- | POST /delete-user, email to delete in "user_email"+deleteUserH :: Pool Connection -> ActionT SproxyError IO ()+deleteUserH pool = do+ userEmail <- param "user_email"+ (t, n) <- checked pool (removeUser userEmail)+ outputFor t n++-- | POST /rename-user:+-- - old email in "old_email"+-- - new email in "new_email"+renameUserH :: Pool Connection -> ActionT SproxyError IO ()+renameUserH pool = do+ oldEmail <- param "old_email"+ newEmail <- param "new_email"+ (resp, n) <- checked pool (renameUser oldEmail newEmail)+ outputFor resp n++-- utility functions++outputFor :: Text -> Int64 -> ActionT SproxyError IO ()+outputFor t 0 = status badRequest400 >> text ("no: " <> t)+outputFor t (-1) = status badRequest400 >> text ("error: " <> t)+outputFor t _ = text t++checked :: Pool Connection+ -> (Connection -> IO Int64) -- request+ -> ActionT SproxyError IO (Text, Int64)+checked pool req =+ withDB pool req'++ where req' c = flip catch (\(e :: SomeException) -> return (Text.pack (show e), -1))+ ( ("",) <$> req c )+
− src/Config.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}--module Config where--import Control.Exception-import Data.ByteString (ByteString)-import Data.Configurator as C-import HFlags-import System.Directory-import System.FilePath--import Paths_sproxy_web--defineFlag "c:config" ("sproxy-web.config" :: String) "config file"--data Config = Config {- dbConnectionString :: ByteString,- port :: Int,- staticDir :: FilePath- }- deriving (Show, Eq)---- | Get the connection string and the port--- from the config file-getConfig :: FilePath -> IO Config-getConfig configFile = do- conf <- C.load [C.Required configFile]- Config <$>- C.require conf "db_connection_string" <*>- C.require conf "port" <*>- getStaticDir--getStaticDir :: IO FilePath-getStaticDir = do- currentDir <- getCurrentDirectory- staticExists <- doesDirectoryExist (currentDir </> "static")- if staticExists then do- return currentDir- else do- cabalDataDir <- getDataDir- cabalDataDirExists <- doesDirectoryExist cabalDataDir- if cabalDataDirExists- then return cabalDataDir- else throwIO (ErrorCall "directory for static files not found.")
src/DB.hs view
@@ -1,28 +1,18 @@-module DB (createDBPool, withDB, DBPool, Connection) where+module DB (+ withDB+) where import Control.Monad.Trans import Data.Pool import Database.PostgreSQL.Simple-import Data.ByteString (ByteString) -type DBPool = Pool Connection---- Initialize our connection pool-createDBPool :: ByteString -> IO DBPool-createDBPool connectionString =- createPool (connectPostgreSQL connectionString)- close- 1 -- stripe count- 100 -- amount of secs it stays alive- 50 -- at most 50 concurrent connections- -- Pick a connection handle from the pool and use it to -- execute the given request. -- The MonadIO bit lets me avoid caring about where this will run, -- although we're always using it in the `ActionT SproxyError IO` monad -- but the more general type signature keeps us from doing anything irrelevant withDB :: MonadIO m - => DBPool + => Pool Connection -> (Connection -> IO a) -> m a withDB pool act = liftIO $ withResource pool (liftIO . act)
− src/Handlers.hs
@@ -1,319 +0,0 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TupleSections #-}--module Handlers where--import DB-import Entities-import SproxyError--import Control.Exception-import Control.Monad (when)-import Data.Int (Int64)-import Data.Monoid-import Data.Text.Lazy as Text-import Network.HTTP.Types.Status-import Web.Scotty.Trans--import Text.Blaze.Html.Renderer.Text (renderHtml)-import Text.Blaze.Html5 (Html)--import Views.DomainList (domainListT)-import Views.DomainPrivileges (domainPrivilegesT)-import Views.ErrorPage (errorPageT)-import Views.GroupList (groupListT)-import Views.Homepage (homepageT)-import Views.MemberList (memberListT)-import Views.PrivilegeRules (privilegeRulesT)-import Views.Search (searchResultsT)--blaze :: Html -> ActionT SproxyError IO ()-blaze = Web.Scotty.Trans.html . renderHtml--handleEx :: SproxyError -> ActionT SproxyError IO ()-handleEx = errorPage--errorPage :: SproxyError -> ActionT SproxyError IO ()-errorPage err = blaze (errorPageT err)--homepage :: DBPool -> ActionT SproxyError IO ()-homepage _ = blaze homepageT----------------------------------------------- handlers related to the group list page----------------------------------------------- POST /groups-jsonUpdateGroup :: DBPool -> ActionT SproxyError IO ()-jsonUpdateGroup pool = do- (operation :: Text) <- param "operation"- (t, n) <- case operation of- "add" -> do- g <- param "group"- checked pool (addGroup g)-- "del" -> do- g <- param "group"- checked pool (removeGroup g)-- "upd" -> do- old <- param "old"- new <- param "new"- checked pool (updateGroup old new)-- _ -> status badRequest400 >> return ("incorrect operation", (-1))-- outputFor t n---- GET /groups-groupList :: DBPool -> ActionT SproxyError IO ()-groupList pool = do- groups <- Prelude.map Prelude.head `fmap` withDB pool getGroups - blaze (groupListT groups)---- GET /groups.json-jsonGroupList :: DBPool -> ActionT SproxyError IO ()-jsonGroupList pool = do- groups <- Prelude.map Prelude.head `fmap` withDB pool getGroups-- json groups-------------------------------------------------------- handlers related to the group members list page-------------------------------------------------------- GET /group/:group-memberList :: DBPool -> ActionT SproxyError IO ()-memberList pool = do- groupName <- param "group"- members <- Prelude.map Prelude.head `fmap` withDB pool (getMembersFor groupName)- blaze (memberListT members groupName)---- POST /group/:group/members-jsonPostMembers :: DBPool -> ActionT SproxyError IO ()-jsonPostMembers pool = do- groupName <- param "group"-- (operation :: Text) <- param "operation"-- (t, n) <- case operation of- "add" -> do- m <- param "member"- checked pool (addMemberTo m groupName)-- "del" -> do- m <- param "member"- checked pool (removeMemberOf m groupName)-- "upd" -> do- old <- param "old"- new <- param "new"- checked pool (updateMemberOf old new groupName)-- _ -> status badRequest400 >> return ("incorrect operation", (-1))-- outputFor t n------------------------------------------- handlers related to the domain list------------------------------------------- GET /domains-domainList :: DBPool -> ActionT SproxyError IO ()-domainList pool = do- domains <- Prelude.map Prelude.head `fmap` withDB pool getDomains- blaze (domainListT domains)---- POST /domains-jsonUpdateDomain :: DBPool -> ActionT SproxyError IO ()-jsonUpdateDomain pool = do- (operation :: Text) <- param "operation"- (t, n) <- case operation of- "add" -> do- d <- param "domain"- checked pool (addDomain d)-- "del" -> do- d <- param "domain"- checked pool (removeDomain d)-- "upd" -> do- old <- param "old"- new <- param "new"- checked pool (updateDomain old new)-- _ -> status badRequest400 >> return ("incorrect operation", (-1))-- outputFor t n------------------------------------------------------------------------------ handlers related to the list of possible privileges for a given domain------------------------------------------------------------------------------ GET /domain/:domain/privileges-domainPrivileges :: DBPool -> ActionT SproxyError IO ()-domainPrivileges pool = do- domain <- param "domain"- privileges <- Prelude.map Prelude.head `fmap` withDB pool (getDomainPrivileges domain)- groups <- Prelude.map Prelude.head `fmap` withDB pool getGroups- groupPrivs <- withDB pool (getGroupPrivsFor domain)-- blaze (domainPrivilegesT domain privileges groups groupPrivs)---- GET /domain/:domain/privileges.json-jsonDomainPrivileges :: DBPool -> ActionT SproxyError IO ()-jsonDomainPrivileges pool = do- domain <- param "domain"- privileges <- Prelude.map Prelude.head `fmap` withDB pool (getDomainPrivileges domain)-- json privileges---- POST /domain/:domain/group_privileges-handleGPs :: DBPool -> ActionT SproxyError IO ()-handleGPs pool = do- domain <- param "domain"-- (operation :: Text) <- param "operation"-- (t, n) <- case operation of- "add" -> do- grp <- param "group"- priv <- param "privilege"- checked pool (addGPFor domain grp priv)-- "del" -> do- grp <- param "group"- priv <- param "privilege"- checked pool (deleteGPOf domain grp priv)-- _ -> status badRequest400 >> return ("incorrect operation", (-1))-- outputFor t n---- POST /domain/:domain/privileges-jsonPostDomainPrivileges :: DBPool -> ActionT SproxyError IO ()-jsonPostDomainPrivileges pool = do- domain <- param "domain"-- (operation :: Text) <- param "operation"-- (t, n) <- case operation of- "add" -> do- p <- param "privilege"- checked pool (addPrivilegeToDomain p domain)-- "del" -> do- p <- param "privilege"- checked pool (removePrivilegeOfDomain p domain)-- "upd" -> do- old <- param "old"- new <- param "new"- checked pool (updatePrivilegeOfDomain old new domain)-- _ -> status badRequest400 >> return ("incorrect operation", (-1))-- outputFor t n------------------------------------------------------------------------------------ handlers related to the rules associated to a given privilege on some domain------------------------------------------------------------------------------------ GET /domain/:domain/privilege/:privilege/rules-privilegeRules :: DBPool -> ActionT SproxyError IO ()-privilegeRules pool = do- -- TODO: check that the domain and privilege exist- domain <- param "domain"- privilege <- param "privilege"- rules <- withDB pool (getRules domain privilege)-- blaze (privilegeRulesT domain privilege rules)---- POST /domain/:domain/privilege/:privilege/rules-jsonPostRule :: DBPool -> ActionT SproxyError IO ()-jsonPostRule pool = do- -- TODO: check that the domain and privilege exist- domain <- param "domain"- privilege <- param "privilege"- operation <- param "operation"- case operation :: Text of- "add" -> addRule domain privilege- "del" -> delRule domain privilege- "upd" -> updRule domain privilege- _ -> status badRequest400 >> text "bad operation"-- where - addRule domain privilege = do- path <- param "path"- method <- param "method"-- (t, n) <- checked pool - (addRuleToPrivilege domain privilege path method)-- outputFor t n-- delRule domain privilege = do- path <- param "path"- method <- param "method"-- (t, n) <- checked pool- (deleteRuleFromPrivilege domain privilege path method)-- outputFor t n-- updRule domain privilege = do- what <- param "what"- - when (what /= "path" && what /= "method") $ text "invalid 'what'"-- let updFunc = if what == "path" then updatePathFor else updateMethodFor-- old <- param ("old" <> what)- new <- param ("new" <> what)- otherField <- param $ if what == "path" then "method" else "path"-- (t, n) <- checked pool- (updFunc domain privilege new old otherField)-- outputFor t n---- | POST /search, search string in "search_query"-searchUserH :: DBPool -> ActionT SproxyError IO ()-searchUserH pool = do- searchStr <- param "search_query"-- matchingEmails <- withDB pool (searchUser searchStr)-- blaze (searchResultsT searchStr matchingEmails)---- | POST /delete-user, email to delete in "user_email"-deleteUserH :: DBPool -> ActionT SproxyError IO ()-deleteUserH pool = do- userEmail <- param "user_email"- (t, n) <- checked pool (removeUser userEmail)- outputFor t n---- | POST /rename-user:--- - old email in "old_email"--- - new email in "new_email"-renameUserH :: DBPool -> ActionT SproxyError IO ()-renameUserH pool = do- oldEmail <- param "old_email"- newEmail <- param "new_email"- (resp, n) <- checked pool (renameUser oldEmail newEmail)- outputFor resp n---- utility functions--outputFor :: Text -> Int64 -> ActionT SproxyError IO ()-outputFor t 0 = status badRequest400 >> text ("no: " <> t)-outputFor t (-1) = status badRequest400 >> text ("error: " <> t)-outputFor t _ = text t--checked :: DBPool- -> (Connection -> IO Int64) -- request- -> ActionT SproxyError IO (Text, Int64)-checked pool req = - withDB pool req'-- where req' c = flip catch (\(e :: SomeException) -> return (Text.pack (show e), -1))- ( ("",) <$> req c )
src/Main.hs view
@@ -1,6 +1,55 @@-module Main where+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} -import Run+module Main (+ main+) where +import Data.Maybe (fromJust)+import Data.Version (showVersion)+import Paths_sproxy_web (getDataDir, version) -- from cabal+import System.Environment (getArgs)+import Text.InterpolatedString.Perl6 (qc)+import qualified System.Console.Docopt.NoTH as O++import Server (server)++usage :: IO String+usage = do+ dataDir <- getDataDir+ return $+ "sproxy-web " ++ showVersion version +++ " web interface to the sproxy database" ++ [qc|++Usage:+ sproxy-web [options]++Options:++ -c, --connstr=CONNSTR PostgreSQL connection string [default: dbname=sproxy]+ -d, --datadir=DIR Data directory including static files [default: {dataDir}]++ -s, --socket=SOCK Listen on this UNIX socket [default: /tmp/sproxy-web.sock]+ -p, --port=PORT Instead of UNIX socket, listen on this TCP port (localhost)++ -h, --help Show this message++|]+ main :: IO ()-main = run+main = do+ doco <- O.parseUsageOrExit =<< usage+ args <- O.parseArgsOrExit doco =<< getArgs+ if args `O.isPresent` O.longOption "help"+ then putStrLn $ O.usage doco+ else do+ let+ port = O.getArg args $ O.longOption "port"+ connstr = fromJust $ O.getArg args $ O.longOption "connstr"+ socket = fromJust $ O.getArg args $ O.longOption "socket"+ datadir = fromJust $ O.getArg args $ O.longOption "datadir"+ let listen = case port of+ Nothing -> Right socket+ Just p -> Left $ read p+ server listen connstr datadir+
+ src/Server.hs view
@@ -0,0 +1,79 @@+module Server+(+ server+) where++import Control.Exception.Base (throwIO, catch, bracket)+import Data.Bits ((.|.))+import Data.ByteString.Char8 (pack)+import Data.Pool (createPool, destroyAllResources)+import Network.Socket (socket, bind, listen, close, maxListenQueue,+ getSocketName, inet_addr,+ Family(AF_UNIX, AF_INET), SocketType(Stream),+ Socket, SockAddr(SockAddrUnix, SockAddrInet))+import Network.Wai.Handler.Warp (Port, defaultSettings, runSettingsSocket)+import System.IO (hPutStrLn, stderr)+import System.IO.Error (isDoesNotExistError)+import System.Posix.Files (removeLink, setFileMode, socketMode,+ ownerReadMode, ownerWriteMode, groupReadMode, groupWriteMode)+import qualified Database.PostgreSQL.Simple as PG++import Application (app)++type Listen = Either Port FilePath+++server :: Listen -> String -> FilePath -> IO ()+server socketSpec connectionString staticDir =+ bracket+ ( do+ sock <- createSocket socketSpec+ pgsql <- createPool+ (PG.connectPostgreSQL $ pack connectionString)+ PG.close+ 1 -- stripes+ 60 -- keep alive (seconds)+ 10 -- max connections+ return (sock, pgsql) )+ ( \(sock, pgsql) -> do+ closeSocket sock+ destroyAllResources pgsql )+ ( \(sock, pgsql) -> do+ listen sock maxListenQueue+ hPutStrLn stderr $ "Static files from `" ++ staticDir ++ "'"+ runSettingsSocket defaultSettings sock =<< app pgsql staticDir )+++createSocket :: Listen -> IO Socket+createSocket (Right path) = do+ removeIfExists path+ sock <- socket AF_UNIX Stream 0+ bind sock $ SockAddrUnix path+ setFileMode path $ socketMode+ .|. ownerWriteMode .|. ownerReadMode+ .|. groupWriteMode .|. groupReadMode+ hPutStrLn stderr $ "Listening on UNIX socket `" ++ path ++ "'"+ return sock+createSocket (Left port) = do+ sock <- socket AF_INET Stream 0+ addr <- inet_addr "127.0.0.1"+ bind sock $ SockAddrInet (fromIntegral port) addr+ hPutStrLn stderr $ "Listening on localhost:" ++ show port+ return sock+++closeSocket :: Socket -> IO ()+closeSocket sock = do+ name <- getSocketName sock+ close sock+ case name of+ SockAddrUnix path -> removeIfExists path+ _ -> return ()+++removeIfExists :: FilePath -> IO ()+removeIfExists fileName = removeLink fileName `catch` handleExists+ where handleExists e+ | isDoesNotExistError e = return ()+ | otherwise = throwIO e+
+ src/Views/Search.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Views.Search where++import Data.Text.Lazy (Text)++import Text.Blaze.Html5+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import qualified Data.Text.Lazy as T+import Views.Common++searchResultsT :: Text -> [(Text, [Text])] -> Html+searchResultsT searchStr matchingMails = + pageT ("Search results") $ do+ H.p ! A.class_ "lead text-center" $ do+ "Emails matching "+ H.i $ "\"" >> toHtml searchStr >> "\""++ H.p ! A.class_ "text-center" $ H.i $+ "(Click on an email to \"rename\" the user in the sproxy database.)"++ H.div ! A.class_ "text-center" ! A.style "margin: 10px auto;" $ + H.table ! A.id "searchtable" ! A.class_ "table table-condensed" $ do+ H.thead $ do+ H.tr $ do+ H.th ! A.width "30%" ! A.class_ "text-center" $ + "Email address"+ H.th ! A.width "40%" ! A.class_ "text-center" $+ "Groups"+ H.th ! A.width "30%" $ mempty+ H.tbody $+ emailsHtml++ H.div ! A.class_ "alert alert-success" ! A.id "updatesuccess" $+ "Successfully updated."++ H.div ! A.class_ "alert alert-error" ! A.id "updateexists" $+ "This is already used."++ H.div ! A.class_ "alert alert-error" ! A.id "updateerror" $+ "An error occured when trying to update the email in the DB."+ + H.script ! A.type_ "text/javascript"+ ! A.src "/static/js/delete-user.js" $ mempty++ H.script ! A.type_ "text/javascript"+ ! A.src "/static/js/rename-user.js" $ mempty++ where emailsHtml = mapM_ emailToHtml matchingMails+ emailToHtml (mail, groups) = + tr $ do+ td ! A.class_ "edit email-edit" $ toHtml mail+ td $ i $ toHtml (T.intercalate ", " groups)+ td $ a ! A.class_ "delete-btn btn btn-danger btn-xs" $ "Delete from all groups"