aboutsummaryrefslogtreecommitdiff
path: root/src/Application.hs
blob: b3d7fb18543f15edc25880fa8785c0d1c7470b43 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Application (
  app
) where

import Control.Monad.Trans (liftIO)
import Data.ByteString.Base64 (encode)
import Data.Default.Class (def)
import Data.Pool (Pool, withResource)
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
import Database.MySQL.Simple (Connection, Only(..), query, execute)
import Network.HTTP.Types (notFound404,  badRequest400)
import Network.Wai (Application, Middleware)
import Network.Wai.Middleware.RequestLogger (Destination(Handle),
  mkRequestLogger, RequestLoggerSettings(destination, outputFormat),
  OutputFormat(Apache), IPAddrSource(FromHeader))
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

app :: Pool Connection -> FilePath -> IO Application
app p f = do
  logger <- mkRequestLogger def{ destination = Handle stderr, outputFormat = Apache FromHeader }
  scottyApp (juanDeLaCosa p logger f)

juanDeLaCosa :: Pool Connection -> Middleware -> FilePath -> ScottyM ()
juanDeLaCosa p logger dataDir = do
  let
    index_html = dataDir ++ "/" ++ "index.html"

  middleware logger

  middleware $ staticPolicy (hasPrefix "static" >-> addBase dataDir)
  get "/" $ file index_html
  get "/index.html" $ file 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 login -> do
      [ 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

apiResetMyPassword :: Pool Connection -> ActionM ()
apiResetMyPassword p =
  header "From" >>= \case
    Nothing -> status badRequest400 >> text "Missing header `From'"
    Just login -> do
      password <- liftIO $ BS.takeWhile (/= '=') . encode <$> getEntropy 13
      _ <- 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)