diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 === diff --git a/sproxy-web.cabal b/sproxy-web.cabal --- a/sproxy-web.cabal +++ b/sproxy-web.cabal @@ -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 diff --git a/src/Application.hs b/src/Application.hs --- a/src/Application.hs +++ b/src/Application.hs @@ -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 ) diff --git a/src/Entities.hs b/src/Entities.hs --- a/src/Entities.hs +++ b/src/Entities.hs @@ -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 = diff --git a/src/LogFormat.hs b/src/LogFormat.hs new file mode 100644 --- /dev/null +++ b/src/LogFormat.hs @@ -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 + diff --git a/src/Server.hs b/src/Server.hs --- a/src/Server.hs +++ b/src/Server.hs @@ -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 diff --git a/src/Views/Common.hs b/src/Views/Common.hs --- a/src/Views/Common.hs +++ b/src/Views/Common.hs @@ -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 + diff --git a/src/Views/DomainList.hs b/src/Views/DomainList.hs --- a/src/Views/DomainList.hs +++ b/src/Views/DomainList.hs @@ -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" + diff --git a/src/Views/DomainPrivileges.hs b/src/Views/DomainPrivileges.hs --- a/src/Views/DomainPrivileges.hs +++ b/src/Views/DomainPrivileges.hs @@ -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" + diff --git a/src/Views/ErrorPage.hs b/src/Views/ErrorPage.hs --- a/src/Views/ErrorPage.hs +++ b/src/Views/ErrorPage.hs @@ -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" + diff --git a/src/Views/GroupList.hs b/src/Views/GroupList.hs --- a/src/Views/GroupList.hs +++ b/src/Views/GroupList.hs @@ -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" + diff --git a/src/Views/MemberList.hs b/src/Views/MemberList.hs --- a/src/Views/MemberList.hs +++ b/src/Views/MemberList.hs @@ -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" diff --git a/src/Views/PrivilegeRules.hs b/src/Views/PrivilegeRules.hs --- a/src/Views/PrivilegeRules.hs +++ b/src/Views/PrivilegeRules.hs @@ -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" + diff --git a/src/Views/Search.hs b/src/Views/Search.hs --- a/src/Views/Search.hs +++ b/src/Views/Search.hs @@ -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" +