diff options
| -rw-r--r-- | Setup.hs | 1 | ||||
| -rw-r--r-- | src/Application.hs | 74 | ||||
| -rw-r--r-- | src/LogFormat.hs | 64 |
3 files changed, 82 insertions, 57 deletions
@@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/src/Application.hs b/src/Application.hs index 8ed2f7e..2005fc7 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -2,60 +2,76 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Application ( - app -) where +module Application + ( app + ) where import Control.Monad.Trans (liftIO) import Data.ByteString.Base64 (encode) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Default.Class (def) import Data.Pool (Pool, withResource) import Data.Text.Lazy (Text, toLower) -import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) -import Database.MySQL.Simple (Connection, Only(..), query, execute) -import Network.HTTP.Types (notFound404, badRequest400) +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import Database.MySQL.Simple (Connection, Only(..), execute, query) +import Network.HTTP.Types (badRequest400, notFound404) import Network.Wai (Application, Middleware) -import Network.Wai.Middleware.RequestLogger (Destination(Handle), - mkRequestLogger, RequestLoggerSettings(destination, outputFormat), - OutputFormat(CustomOutputFormat)) -import Network.Wai.Middleware.Static (addBase, hasPrefix, staticPolicy, (>->)) +import Network.Wai.Middleware.RequestLogger + ( Destination(Handle) + , OutputFormat(CustomOutputFormat) + , RequestLoggerSettings(destination, outputFormat) + , mkRequestLogger + ) +import Network.Wai.Middleware.Static ((>->), addBase, hasPrefix, staticPolicy) import System.Entropy (getEntropy) import System.IO (stderr) -import Web.Scotty (ScottyM, ActionM, header, middleware, file, get, post, - status, text, scottyApp) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS +import Web.Scotty + ( ActionM + , ScottyM + , file + , get + , header + , middleware + , post + , scottyApp + , status + , text + ) import LogFormat (logFormat) - app :: Pool Connection -> FilePath -> IO Application app p f = do - logger <- mkRequestLogger def{ destination = Handle stderr - , outputFormat = CustomOutputFormat logFormat } + logger <- + mkRequestLogger + def + { destination = Handle stderr + , outputFormat = CustomOutputFormat logFormat + } scottyApp (juanDeLaCosa p logger f) juanDeLaCosa :: Pool Connection -> Middleware -> FilePath -> ScottyM () juanDeLaCosa p logger dataDir = do middleware logger - middleware $ staticPolicy (hasPrefix "static" >-> addBase dataDir) get "/" $ file (dataDir ++ "/" ++ "index.html") - post "/resetMyPassword" $ apiResetMyPassword p get "/whoAmI" $ apiWhoAmI p - apiWhoAmI :: Pool Connection -> ActionM () apiWhoAmI p = header "From" >>= \case Nothing -> status badRequest400 >> text "Missing header `From'" Just email -> do let login = emailToLogin email - [ Only n ] <- withDB p $ \c -> - query c "SELECT COUNT(*) FROM mysql.user WHERE User=? AND Host='%'" - [ LBS.toStrict . encodeUtf8 $ login ] - if (n::Int) > 0 + [Only n] <- + withDB p $ \c -> + query + c + "SELECT COUNT(*) FROM mysql.user WHERE User=? AND Host='%'" + [LBS.toStrict . encodeUtf8 $ login] + if (n :: Int) > 0 then text login else status notFound404 >> text login @@ -66,14 +82,16 @@ apiResetMyPassword p = Just email -> do let login = emailToLogin email password <- liftIO $ BS.takeWhile (/= '=') . encode <$> getEntropy 13 - _ <- withDB p $ \c -> execute c "SET PASSWORD FOR ?@'%' = PASSWORD(?)" - [ LBS.toStrict . encodeUtf8 $ login, password ] + _ <- + withDB p $ \c -> + execute + c + "SET PASSWORD FOR ?@'%' = PASSWORD(?)" + [LBS.toStrict . encodeUtf8 $ login, password] text . decodeUtf8 . LBS.fromStrict $ password - withDB :: Pool Connection -> (Connection -> IO a) -> ActionM a withDB p a = liftIO $ withResource p (liftIO . a) emailToLogin :: Text -> Text emailToLogin = toLower - diff --git a/src/LogFormat.hs b/src/LogFormat.hs index 9eb25f1..0f75079 100644 --- a/src/LogFormat.hs +++ b/src/LogFormat.hs @@ -1,40 +1,46 @@ {-# LANGUAGE OverloadedStrings #-} -module LogFormat ( - logFormat -) where +module LogFormat + ( logFormat + ) where +import qualified Data.ByteString.Char8 as BS import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Network.HTTP.Types (Status(statusCode)) -import Network.Wai (Request, httpVersion, requestHeaders, requestMethod, - rawPathInfo, requestHeaderReferer, requestHeaderUserAgent) +import Network.Wai + ( Request + , httpVersion + , rawPathInfo + , requestHeaderReferer + , requestHeaderUserAgent + , requestHeaders + , requestMethod + ) import System.Log.FastLogger (LogStr, toLogStr) -import qualified Data.ByteString.Char8 as BS -- Sligthly modified Combined 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 - +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 |