Main.hs

module Main ( newUniqueCallHistory
            , main ) where

import Control.Applicative ((<|>), liftA2)
import Data.Maybe (fromMaybe)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as L
import Text.Read (readMaybe)
import Data.List.Extra (lower)
import qualified Data.Sequence as S
import Lib (boundedPushRight)
import MainHelper (CallHistory(..), newUniqueCallHistory)
import Control.Concurrent.MVar
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Foldable as F
import Data.Time ( getCurrentTime
                 , formatTime
                 , defaultTimeLocale
                 , TimeZone(..)
                 , utcToZonedTime
                 )
import Lucid
import System.Environment (lookupEnv)
import Network.HTTP.Types (StdMethod(HEAD) , status404)
import Web.Scotty

{-# ANN module ("HLint: ignore Redundant do" :: String) #-}

data RuntimeConfig = RuntimeConfig {
      rcServeHistoryPage :: Bool
    , rcHistorySize :: Int
    , rcCallHistory :: MVar (S.Seq CallHistory)
    , rcUniqueCallHistory :: MVar (S.Seq CallHistory)
    }

data HistoryType = AllHistory
                 | UniqueHistory

getClientIP1 :: ActionM (Maybe Text)
getClientIP1 = header "CLIENT-IP"

getClientIP2 :: ActionM (Maybe Text)
getClientIP2 =
  fmap (fmap firstElement) (header "X-FORWARDED-FOR") where
      firstElement :: Text -> Text
      firstElement = head . L.splitOn ","

getClientIP3 :: ActionM (Maybe Text)
getClientIP3 = foldl1 (liftA2 (<|>)) $ map header ["X-FORWARDED"
                                                  ,"X-CLUSTER-CLIENT-IP"
                                                  ,"FORWARDED-FOR"
                                                  ,"FORWARDED"
                                                  ,"REMOTE-ADDR"]

-- | get current time in CST timezone.
getCurrentTimeCST :: IO Text
getCurrentTimeCST = do
  now <- getCurrentTime
  let tz = TimeZone { timeZoneMinutes=480
                    , timeZoneSummerOnly=False
                    , timeZoneName="CST"}
  return $ L.pack $ formatTime defaultTimeLocale "%c %z" (utcToZonedTime tz now)

-- | if rcServeHistoryPage is enabled, add call history to rcCallHistory Seq.
writeCallHistoryMaybe :: RuntimeConfig -> Text -> ActionM ()
writeCallHistoryMaybe rc rawIP =
    when (rcServeHistoryPage rc) $ do
      time <- liftIO getCurrentTimeCST
      userAgent <- header "User-Agent"
      !callHistory <- liftIO $ takeMVar (rcCallHistory rc)
      !uniqueCallHistory <- liftIO $ takeMVar (rcUniqueCallHistory rc)
      let newEntry = CallHistory {
                       chTime = time
                     , chClientIP = rawIP
                     , chUserAgent = fromMaybe "unknown" userAgent}
      liftIO $ putMVar (rcCallHistory rc)
                       (boundedPushRight callHistory (rcHistorySize rc) newEntry)
      liftIO $ putMVar (rcUniqueCallHistory rc)
                       (newUniqueCallHistory uniqueCallHistory
                                             (rcHistorySize rc)
                                             newEntry)

getClientIP :: RuntimeConfig -> ActionM ()
getClientIP rc = do
  ip <- foldl1 (liftA2 (<|>)) [getClientIP1, getClientIP2, getClientIP3]
  let rawIP = fromMaybe "unknown" ip
  text $ rawIP <> "\n"
  writeCallHistoryMaybe rc rawIP

-- | look up an environment variable, if it doesn't exist or is empty, use
-- default value instead. Otherwise, call a reader function on it and use that
-- value if parse is okay, use default value if parse fail.
getEnvDefault :: String -> a -> (String -> Maybe a) -> IO a
getEnvDefault variable defaultValue stringReader = do
    r <- lookupEnv variable
    return $ case r of
      Nothing -> defaultValue
      Just [] -> defaultValue
      Just xs -> fromMaybe defaultValue (stringReader xs)

readBoolMaybe :: String -> Maybe Bool
readBoolMaybe str = Just (lower str `elem` ["true", "yes", "1"])

getHistory :: RuntimeConfig -> HistoryType -> MVar (S.Seq CallHistory)
getHistory rc historyType =
    case historyType of
      AllHistory -> rcCallHistory rc
      UniqueHistory -> rcUniqueCallHistory rc

buildHistoryText :: RuntimeConfig -> HistoryType -> IO Text
buildHistoryText rc historyType = do
    callHistory <- readMVar $ getHistory rc historyType
    return $ F.foldl' (\out ch -> out <> chClientIP ch <> ", "
                                      <> chTime ch <> ", "
                                      <> chUserAgent ch <> "\n")
                      "time, client ip, user-agent\n" callHistory

buildHistoryHtml :: RuntimeConfig -> HistoryType -> IO Text
buildHistoryHtml rc historyType = do
    callHistory <- readMVar $ getHistory rc historyType
    let thead = tr_ $ do
                  th_ "client ip"
                  th_ "time"
                  th_ "user-agent"
    let tbody = F.mapM_
                (\ch -> tr_ $ do
                           td_ $ toHtml $ chClientIP ch
                           td_ $ toHtml $ chTime ch
                           td_ $ toHtml $ chUserAgent ch) callHistory
    return $ renderText $ do
      doctype_
      html_ [lang_ "en"] $ do
        head_ $ do
          title_ "recent calls"
        body_ $ do
          p_ $ toHtml $ "recent " <> show (rcHistorySize rc) <> " entries are saved"
          table_ $ do
            thead
            tbody

showHistory :: RuntimeConfig -> HistoryType -> ActionM ()
showHistory rc historyType =
  if rcServeHistoryPage rc then
      do
        accept <- header "accept"
        case accept of
          Just "text/plain" -> do
            result <- liftIO $ buildHistoryText rc historyType
            text result
          _ -> do
            history <- liftIO $ buildHistoryHtml rc historyType
            html history
  else
      status status404

main :: IO ()
main = do
  port <- getEnvDefault "PORT" 8081 readMaybe
  serveHistoryPage <- getEnvDefault "SERVE_HISTORY_PAGE" False readBoolMaybe
  historySize <- getEnvDefault "HISTORY_SIZE" 10 readMaybe
  when serveHistoryPage $ do
    putStrLn "Enabled history api"
    putStrLn $ "Keep a maximum of " <> show historySize <> " call history"
  callHistory <- newMVar S.empty
  uniqueCallHistory <- newMVar S.empty
  let rc = RuntimeConfig { rcServeHistoryPage = serveHistoryPage
                         , rcHistorySize = historySize
                         , rcCallHistory = callHistory
                         , rcUniqueCallHistory = uniqueCallHistory}
  scotty port $ do
    get "/" (getClientIP rc)
    get "/_calls" (showHistory rc AllHistory)
    get "/_calls/unique" (showHistory rc UniqueHistory)
    addroute HEAD "/" $ return ()