sproxy-web 0.4 → 0.4.1
raw patch · 14 files changed
+121/−63 lines, 14 filesdep +fast-loggerdep −configurator
Dependencies added: fast-logger
Dependencies removed: configurator
Files
- ChangeLog.md +8/−0
- sproxy-web.cabal +3/−2
- src/Application.hs +15/−11
- src/Entities.hs +3/−2
- src/LogFormat.hs +40/−0
- src/Server.hs +10/−9
- src/Views/Common.hs +3/−5
- src/Views/DomainList.hs +6/−5
- src/Views/DomainPrivileges.hs +10/−9
- src/Views/ErrorPage.hs +3/−2
- src/Views/GroupList.hs +6/−5
- src/Views/MemberList.hs +4/−4
- src/Views/PrivilegeRules.hs +5/−4
- src/Views/Search.hs +5/−5
ChangeLog.md view
@@ -1,15 +1,23 @@+0.4.1+=====++ * Changed log out format to Combined++ 0.4 === * Listen on UNIX socket (default), TCP allowed on localhost only. * Use command-line options instead of configuration file + 0.3.1 ===== * Use placeholders instead of initial values in input fields * Deleted duplicate "Home" link * Removed a joke about $5/month+ 0.3 ===
sproxy-web.cabal view
@@ -1,5 +1,5 @@ name: sproxy-web-version: 0.4+version: 0.4.1 synopsis: Web interface to sproxy database description: Web frontend for managing sproxy.@@ -39,6 +39,7 @@ Application DB Entities+ LogFormat Server SproxyError Views.Common@@ -56,10 +57,10 @@ , blaze-html >= 0.7 , blaze-markup >= 0.6 , bytestring >= 0.10- , configurator >= 0.2 , data-default-class , directory , docopt >= 0.7+ , fast-logger , filepath , http-types >= 0.8 , interpolatedstring-perl6
src/Application.hs view
@@ -16,7 +16,9 @@ import Database.PostgreSQL.Simple (Connection) import Network.HTTP.Types.Status import Network.Wai (Application, Middleware)-import Network.Wai.Middleware.RequestLogger+import Network.Wai.Middleware.RequestLogger (Destination(Handle),+ mkRequestLogger, RequestLoggerSettings(destination, outputFormat),+ OutputFormat(CustomOutputFormat)) import Network.Wai.Middleware.Static import System.IO import Text.Blaze.Html.Renderer.Text (renderHtml)@@ -31,20 +33,22 @@ import Views.Search (searchResultsT) import Web.Scotty.Trans -import SproxyError import DB import Entities+import LogFormat (logFormat)+import SproxyError app :: Pool Connection -> FilePath -> IO Application app c p = do- logger <- mkRequestLogger def{ destination = Handle stderr }+ logger <- mkRequestLogger def{ destination = Handle stderr+ , outputFormat = CustomOutputFormat logFormat } scottyAppT id (sproxyWeb c p logger) sproxyWeb :: Pool Connection -> FilePath -> Middleware -> ScottyT SproxyError IO ()-sproxyWeb pool staticDirectory logger = do+sproxyWeb pool dataDirectory logger = do middleware logger - middleware (staticPolicy (hasPrefix "static" >-> addBase staticDirectory))+ middleware (staticPolicy (hasPrefix "static" >-> addBase dataDirectory)) -- error page for uncaught exceptions defaultHandler handleEx@@ -115,7 +119,7 @@ new <- param "new" checked pool (updateGroup old new) - _ -> status badRequest400 >> return ("incorrect operation", (-1))+ _ -> status badRequest400 >> return ("incorrect operation", -1) outputFor t n @@ -164,7 +168,7 @@ new <- param "new" checked pool (updateMemberOf old new groupName) - _ -> status badRequest400 >> return ("incorrect operation", (-1))+ _ -> status badRequest400 >> return ("incorrect operation", -1) outputFor t n @@ -196,7 +200,7 @@ new <- param "new" checked pool (updateDomain old new) - _ -> status badRequest400 >> return ("incorrect operation", (-1))+ _ -> status badRequest400 >> return ("incorrect operation", -1) outputFor t n @@ -240,7 +244,7 @@ priv <- param "privilege" checked pool (deleteGPOf domain grp priv) - _ -> status badRequest400 >> return ("incorrect operation", (-1))+ _ -> status badRequest400 >> return ("incorrect operation", -1) outputFor t n @@ -265,7 +269,7 @@ new <- param "new" checked pool (updatePrivilegeOfDomain old new domain) - _ -> status badRequest400 >> return ("incorrect operation", (-1))+ _ -> status badRequest400 >> return ("incorrect operation", -1) outputFor t n @@ -370,6 +374,6 @@ checked pool req = withDB pool req' - where req' c = flip catch (\(e :: SomeException) -> return (Text.pack (show e), -1))+ where req' c = handle (\(e :: SomeException) -> return (Text.pack (show e), -1)) ( ("",) <$> req c )
src/Entities.hs view
@@ -2,6 +2,7 @@ module Entities where +import Control.Arrow (second) import Data.Int import Data.Monoid import Data.Text.Lazy (Text)@@ -212,14 +213,14 @@ -- | Search an user. Returns a list of matching emails searchUser :: Text -> Connection -> IO [(Text, [Text])]-searchUser searchQuery conn = fmap postprocess $+searchUser searchQuery conn = postprocess <$> query conn "SELECT email::text, array_agg(\"group\") \ \ FROM group_member \ \ WHERE email LIKE ? \ \ GROUP BY email" (Only $ "%" <> searchQuery <> "%") - where postprocess = map (\(mail, groups) -> (mail, fromPGArray groups))+ where postprocess = map (second fromPGArray) renameUser :: Text -> Text -> Connection -> IO Int64 renameUser oldemail newemail conn =
+ src/LogFormat.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++module LogFormat (+ logFormat+) where++import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Network.HTTP.Types (Status(statusCode))+import Network.Wai (Request, httpVersion, requestHeaders, requestMethod,+ rawPathInfo, requestHeaderReferer, requestHeaderUserAgent)+import System.Log.FastLogger (LogStr, toLogStr)+import qualified Data.ByteString.Char8 as BS++-- Sligthly modified Common Log Format.+-- User ID extracted from the From header.+logFormat :: BS.ByteString -> Request -> Status -> Maybe Integer -> LogStr+logFormat t req st msize = ""+ <> toLogStr (fromMaybe "-" $ lookup "X-Forwarded-For" headers)+ <> " - "+ <> toLogStr (fromMaybe "-" $ lookup "From" headers)+ <> " ["+ <> toLogStr t+ <> "] \""+ <> toLogStr (requestMethod req)+ <> " "+ <> toLogStr (rawPathInfo req)+ <> " "+ <> toLogStr (show $ httpVersion req)+ <> "\" "+ <> toLogStr (show $ statusCode st)+ <> " "+ <> toLogStr (maybe "-" show msize)+ <> " \""+ <> toLogStr (fromMaybe "" $ requestHeaderReferer req)+ <> "\" \""+ <> toLogStr (fromMaybe "" $ requestHeaderUserAgent req)+ <> "\"\n"+ where headers = requestHeaders req+
src/Server.hs view
@@ -7,15 +7,15 @@ 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.Socket (socket, setSocketOption, bind, listen, close,+ maxListenQueue, getSocketName, inet_addr, Family(AF_UNIX, AF_INET),+ SocketType(Stream), SocketOption(ReuseAddr), 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 System.Posix.Files (removeLink, setFileMode, socketMode, ownerReadMode,+ ownerWriteMode, groupReadMode, groupWriteMode) import qualified Database.PostgreSQL.Simple as PG import Application (app)@@ -24,7 +24,7 @@ server :: Listen -> String -> FilePath -> IO ()-server socketSpec connectionString staticDir =+server socketSpec connectionString dataDir = bracket ( do sock <- createSocket socketSpec@@ -40,8 +40,8 @@ destroyAllResources pgsql ) ( \(sock, pgsql) -> do listen sock maxListenQueue- hPutStrLn stderr $ "Static files from `" ++ staticDir ++ "'"- runSettingsSocket defaultSettings sock =<< app pgsql staticDir )+ hPutStrLn stderr $ "Static files from `" ++ dataDir ++ "'"+ runSettingsSocket defaultSettings sock =<< app pgsql dataDir ) createSocket :: Listen -> IO Socket@@ -56,6 +56,7 @@ return sock createSocket (Left port) = do sock <- socket AF_INET Stream 0+ setSocketOption sock ReuseAddr 1 addr <- inet_addr "127.0.0.1" bind sock $ SockAddrInet (fromIntegral port) addr hPutStrLn stderr $ "Listening on localhost:" ++ show port
src/Views/Common.hs view
@@ -23,7 +23,7 @@ H.option ! A.value (toValue option) $ toHtml option pageT :: Text -> Html -> Html-pageT t cont = do+pageT t cont = docTypeHtml ! lang "en" $ do H.head $ do H.title (toHtml t)@@ -45,7 +45,7 @@ body $ do - H.div ! A.class_ "navbar navbar-inverse navbar-fixed-top" $ do+ H.div ! A.class_ "navbar navbar-inverse navbar-fixed-top" $ H.div ! A.class_ "container" $ do -- header for the navbar@@ -75,6 +75,4 @@ H.div ! A.class_ "page-header text-center" $ H.h1 $ toHtml t cont- - -- Latest compiled and minified JavaScript- -- script ! A.type_ "text/javascript" ! src "/static/js/jquery-1.10.2.min.js" $ mempty+
src/Views/DomainList.hs view
@@ -20,20 +20,20 @@ H.div ! A.class_ "text-center" ! A.style "margin: 10px auto;" $ H.table ! A.id "edittable" ! A.class_ "table table-condensed" $ do- H.thead $ do+ H.thead $ H.tr $ do H.th ! A.width "50%" ! A.class_ "text-center" $ "Domain name" H.th ! A.width "30%" $ mempty H.th ! A.width "20%" $ mempty- H.tbody $ do+ H.tbody $ mapM_ domainToHtml gs- H.tfoot $ do+ H.tfoot $ H.tr $ do H.td $ inp "domain" "example.org" H.td $ H.button ! A.class_ "btn btn-success btn-xs add-btn" $ "Add a domain"- H.td $ mempty+ H.td mempty H.div ! A.class_ "alert alert-success" ! A.id "updatesuccess" $ "Successfully updated."@@ -47,7 +47,7 @@ H.script ! A.type_ "text/javascript" ! A.src "/static/js/domainlist.js" $ mempty - where domainToHtml d = do+ where domainToHtml d = tr $ do td ! A.class_ "edit domain-edit" $ toHtml d td $@@ -56,3 +56,4 @@ a ! href "#" ! A.class_ "privileges-btn btn btn-link btn-xs" $ "Privileges"+
src/Views/DomainPrivileges.hs view
@@ -32,20 +32,20 @@ H.div ! A.class_ "text-center" ! A.style "margin: 10px auto;" $ H.table ! A.id "edittable" ! A.class_ "table table-condensed" $ do- H.thead $ do+ H.thead $ H.tr $ do H.th ! A.width "50%" ! A.class_ "text-center" $ "Privilege" H.th ! A.width "30%" $ mempty H.th ! A.width "20%" $ mempty- H.tbody $ do+ H.tbody $ mapM_ privToHtml privileges- H.tfoot $ do+ H.tfoot $ H.tr $ do H.td $ inp "privilege" "Privilege name" H.td $ H.button ! A.class_ "btn btn-success btn-xs add-btn" $ "Add a privilege"- H.td $ mempty+ H.td mempty H.div ! A.class_ "alert alert-success" ! A.id "updatesuccess" $ "Successfully updated."@@ -65,16 +65,16 @@ H.div ! A.class_ "text-center" ! A.style "margin: 10px auto;" $ H.table ! A.id "edittable2" ! A.class_ "table table-condensed" $ do- H.thead $ do+ H.thead $ H.tr $ do H.th ! A.width "40%" ! A.class_ "text-center" $ "Group" H.th ! A.width "40%" ! A.class_ "text-center" $ "Privilege" H.th ! A.width "20%" $ mempty- H.tbody $ do+ H.tbody $ mapM_ groupPrivToHtml groupPrivs- H.tfoot $ do+ H.tfoot $ H.tr $ do H.td $ sel "groupSel" groups H.td $ sel "privSel" privileges@@ -90,7 +90,7 @@ H.script ! A.type_ "text/javascript" ! A.src "/static/js/domainprivileges.js" $ mempty - where privToHtml p = do+ where privToHtml p = tr $ do td ! A.class_ "edit privilege-edit" $ toHtml p td $ @@ -100,9 +100,10 @@ ! class_ "rule-btn btn btn-link btn-xs" $ "Rules" - groupPrivToHtml (group, priv) = do+ groupPrivToHtml (group, priv) = tr $ do td $ toHtml group td $ toHtml priv td $ a ! A.class_ "delete-gp-btn btn btn-danger btn-xs" $ "Delete"+
src/Views/ErrorPage.hs view
@@ -10,8 +10,9 @@ import Views.Common errorPageT :: SproxyError -> Html-errorPageT err = do- pageT "Error!" $ do+errorPageT err =+ pageT "Error!" $ H.div ! class_ "alert alert-error text-center" $ do p $ toHtml (show err) p $ a ! href "##" ! onclick "history.go(-1); return false;" $ "Go back"+
src/Views/GroupList.hs view
@@ -20,20 +20,20 @@ H.div ! A.class_ "text-center" ! A.style "margin: 10px auto;" $ H.table ! A.id "edittable" ! A.class_ "table table-condensed" $ do- H.thead $ do+ H.thead $ H.tr $ do H.th ! A.width "50%" ! A.class_ "text-center" $ "Group name" H.th ! A.width "30%" $ mempty H.th ! A.width "20%" $ mempty- H.tbody $ do+ H.tbody $ mapM_ groupToHtml gs- H.tfoot $ do+ H.tfoot $ H.tr $ do H.td $ inp "gname" "Some Group" H.td $ H.button ! A.class_ "btn btn-success btn-xs add-btn" $ "Add a group"- H.td $ mempty+ H.td mempty H.div ! A.class_ "alert alert-success" ! A.id "updatesuccess" $ "Successfully updated."@@ -47,7 +47,7 @@ H.script ! A.type_ "text/javascript" ! A.src "/static/js/grouplist.js" $ mempty - where groupToHtml gname = do+ where groupToHtml gname = tr $ do td ! A.class_ "edit group-edit" $ toHtml gname td $@@ -56,3 +56,4 @@ a ! href "#" ! A.class_ "member-btn btn btn-link btn-xs" $ "Members"+
src/Views/MemberList.hs view
@@ -27,14 +27,14 @@ H.div ! A.class_ "text-center" ! A.style "margin: 10px auto;" $ H.table ! A.id "edittable" ! A.class_ "table table-condensed" $ do- H.thead $ do+ H.thead $ H.tr $ do H.th ! A.width "70%" ! A.class_ "text-center" $ "Member" H.th ! A.width "30%" $ mempty- H.tbody $ do+ H.tbody $ mapM_ memberToHtml members- H.tfoot $ do+ H.tfoot $ H.tr $ do H.td $ inp "member" "%@example.com" H.td $ H.button ! A.class_ "btn btn-success btn-xs add-btn"@@ -52,7 +52,7 @@ H.script ! A.type_ "text/javascript" ! A.src "/static/js/memberlist.js" $ mempty - where memberToHtml m = do+ where memberToHtml m = tr $ do td ! A.class_ "edit member-edit" $ toHtml m td $ a ! A.class_ "delete-btn btn btn-danger btn-xs" $ "Delete"
src/Views/PrivilegeRules.hs view
@@ -33,16 +33,16 @@ H.div ! A.class_ "text-center" ! A.style "margin: 10px auto;" $ do H.table ! A.id "edittable" ! A.class_ "table table-condensed" $ do- H.thead $ do+ H.thead $ H.tr $ do H.th ! A.width "50%" ! A.class_ "text-center" $ "Path" H.th ! A.width "30%" ! A.class_ "text-center" $ "Method" H.th ! A.width "20%" $ mempty- H.tbody $ do+ H.tbody $ mapM_ ruleToHtml rules- H.tfoot $ do+ H.tfoot $ H.tr $ do H.td $ inp "path" "%, /, /path, etc." H.td $ inp "method" "GET, POST, etc."@@ -64,8 +64,9 @@ H.script ! A.type_ "text/javascript" ! A.src "/static/js/rules.js" $ mempty - where ruleToHtml (path, method) = do+ where ruleToHtml (path, method) = tr $ do td ! A.class_ "path-edit edit" $ toHtml path td ! A.class_ "method-edit edit" $ toHtml method td $ a ! A.class_ "delete-btn btn btn-danger btn-xs" $ "Delete"+
src/Views/Search.hs view
@@ -12,16 +12,16 @@ searchResultsT :: Text -> [(Text, [Text])] -> Html searchResultsT searchStr matchingMails = - pageT ("Search results") $ do+ 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 $+ 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.table ! A.id "searchtable" ! A.class_ "table table-condensed" $ H.thead $ do H.tr $ do H.th ! A.width "30%" ! A.class_ "text-center" $ @@ -29,8 +29,7 @@ H.th ! A.width "40%" ! A.class_ "text-center" $ "Groups" H.th ! A.width "30%" $ mempty- H.tbody $- emailsHtml+ H.tbody emailsHtml H.div ! A.class_ "alert alert-success" ! A.id "updatesuccess" $ "Successfully updated."@@ -53,3 +52,4 @@ 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"+