aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Application.hs74
-rw-r--r--src/LogFormat.hs64
2 files changed, 81 insertions, 57 deletions
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