fradrive/src/Application.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Application
    ( getAppDevSettings
    , appMain
    , develMain
    , makeFoundation
    , makeLogWare
    -- * for DevelMain
    , foundationStoreNum
    , getApplicationRepl
    , shutdownApp
    -- * for GHCI
    , handler
    , db
    , addPWEntry
    ) where

import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                             pgPoolSize, runSqlPool)
import Import
import Language.Haskell.TH.Syntax           (qLocation)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp             (Settings, defaultSettings,
                                             defaultShouldDisplayException,
                                             runSettingsSocket, setHost,
                                             setBeforeMainLoop,
                                             setOnException, setPort, getPort)
import Data.Streaming.Network               (bindPortTCP)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
                                             IPAddrSource (..),
                                             OutputFormat (..), destination,
                                             mkRequestLogger, outputFormat)
import System.Log.FastLogger                ( defaultBufSize, newStderrLoggerSet, newStdoutLoggerSet, newFileLoggerSet
                                            , toLogStr, rmLoggerSet
                                            )

import qualified Data.Map.Strict as Map

import Foreign.Store

import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID

import System.Directory
import System.FilePath

import Jobs

import qualified Data.Text.Encoding as Text
import Yesod.Auth.Util.PasswordStore

import qualified Data.ByteString.Lazy as LBS

import Network.HaskellNet.SSL hiding (Settings)
import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)
import Data.Pool

import Control.Monad.Trans.Resource

import System.Log.FastLogger.Date
import qualified Yesod.Core.Types as Yesod (Logger(..))

import qualified Data.HashMap.Strict as HashMap

import Utils.Lens

import Data.Proxy

import qualified Data.Aeson as Aeson

import System.Exit

import qualified Database.Memcached.Binary.IO as Memcached

import qualified System.Systemd.Daemon as Systemd
import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel)
import System.Environment (lookupEnv)
import System.Posix.Process (getProcessID)
import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM)
import qualified System.Posix.Signals as Signals (Handler(..))

import Control.Monad.Trans.State (execStateT)

import Network (socketPort)
import qualified Network.Socket as Socket (close)

-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)
import Handler.Common
import Handler.Home
import Handler.Info
import Handler.Help
import Handler.Profile
import Handler.Users
import Handler.Admin
import Handler.Term
import Handler.School
import Handler.Course
import Handler.Sheet
import Handler.Submission
import Handler.Tutorial
import Handler.Corrections
import Handler.Material
import Handler.CryptoIDDispatch
import Handler.SystemMessage
import Handler.Health


-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
-- comments there for more details.
mkYesodDispatch "UniWorX" resourcesUniWorX

-- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
makeFoundation appSettings'@AppSettings{..} = do
    -- Some basic initializations: HTTP connection manager, logger, and static
    -- subsite.
    appHttpManager <- newManager
    appLogSettings <- liftIO $ newTVarIO appInitialLogSettings

    let
      mkLogger LogSettings{..} = do
        tgetter <- newTimeCache "%Y-%m-%d %T %z"
        loggerSet <- case logDestination of
          LogDestStderr -> newStderrLoggerSet defaultBufSize
          LogDestStdout -> newStdoutLoggerSet defaultBufSize
          LogDestFile{..} -> newFileLoggerSet defaultBufSize logDestFile
        return $ Yesod.Logger loggerSet tgetter
      mkLogger' = liftIO $ do
        initialSettings <- readTVarIO appLogSettings
        tVar <- newTVarIO =<< mkLogger initialSettings
        let updateLogger prevSettings = do
              newSettings <- atomically $ do
                newSettings <- readTVar appLogSettings
                guard $ newSettings /= prevSettings
                return newSettings
              oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings
              rmLoggerSet $ loggerSet oldLogger
              updateLogger newSettings
        (tVar, ) <$> fork (updateLogger initialSettings)
    appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet))

    let appStatic = embeddedStatic

    appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID

    appJobCtl <- liftIO $ newTVarIO Map.empty
    appCronThread <- liftIO newEmptyTMVarIO
    appHealthReport <- liftIO $ newTVarIO Nothing

    -- We need a log function to create a connection pool. We need a connection
    -- pool to create our foundation. And we need our foundation to get a
    -- logging function. To get out of this loop, we initially create a
    -- temporary foundation without a real connection pool, get a log function
    -- from there, and then create the real foundation.
    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..}
        -- The UniWorX {..} syntax is an example of record wild cards. For more
        -- information, see:
        -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
        tempFoundation = mkFoundation
          (error "connPool forced in tempFoundation")
          (error "smtpPool forced in tempFoundation")
          (error "ldapPool forced in tempFoundation")
          (error "cryptoIDKey forced in tempFoundation")
          (error "sessionKey forced in tempFoundation")
          (error "secretBoxKey forced in tempFoundation")
          (error "widgetMemcached forced in tempFoundation")
          (error "JSONWebKeySet forced in tempFoundation")
          (error "ClusterID forced in tempFoundation")

    runAppLoggingT tempFoundation $ do
      $logInfoS "InstanceID" $ UUID.toText appInstanceID
      -- logDebugS "Configuration" $ tshow appSettings'

      smtpPool <- for appSmtpConf $ \c -> do
        $logDebugS "setup" "SMTP-Pool"
        createSmtpPool c

      appWidgetMemcached <- for appWidgetMemcachedConf $ \c -> do
        $logDebugS "setup" "Widget-Memcached"
        createWidgetMemcached c

      -- Create the database connection pool
      $logDebugS "setup" "PostgreSQL-Pool"
      sqlPool <- createPostgresqlPool
        (pgConnStr  appDatabaseConf)
        (pgPoolSize appDatabaseConf)

      ldapPool <- for appLdapConf $ \LdapConf{..} -> do
        $logDebugS "setup" "LDAP-Pool"
        createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)

      -- Perform database migration using our application's logging settings.
      if
        | appAutoDbMigrate -> do
            $logDebugS "setup" "Migration"
            migrateAll `runSqlPool` sqlPool
        | otherwise -> whenM (requiresMigration `runSqlPool` sqlPool) $ do
            $logErrorS "setup" "Migration required"
            liftIO . exitWith $ ExitFailure 2
      $logDebugS "setup" "Cluster-Config"
      appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
      appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
      appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
      appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
      appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool

      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID

      -- Return the foundation
      $logDebugS "setup" "Done"
      return foundation

runAppLoggingT :: UniWorX -> LoggingT m a -> m a
runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
  where
    logFunc loc src lvl str = do
      f <- messageLoggerSource app <$> readTVarIO loggerTVar
      f loc src lvl str

clusterSetting :: forall key m p.
                  ( MonadIO m
                  , ClusterSetting key
                  , MonadLogger m
                  )
               => p (key :: ClusterSettingsKey)
               -> ReaderT SqlBackend m (ClusterSettingValue key)
clusterSetting proxy@(knownClusterSetting -> key) = do
  current' <- get (ClusterConfigKey key)
  case Aeson.fromJSON . clusterConfigValue <$> current' of
    Just (Aeson.Success c) -> return c
    Just (Aeson.Error str) -> do
      $logErrorS "clusterSetting" $ "Could not parse JSON-Value for " <> toPathPiece key <> ": " <> pack str
      liftIO exitFailure
    Nothing -> do
      new <- initClusterSetting proxy
      void . insert $ ClusterConfig key (Aeson.toJSON new)
      return new

readInstanceIDFile :: MonadIO m => FilePath -> m UUID
readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
  where
    parseBS :: LBS.ByteString -> IO UUID
    parseBS = maybe (throwString "appInstanceIDFile does not contain an UUID encoded in network byte order") return . UUID.fromByteString
    generateInstead :: IOException -> IO UUID
    generateInstead e
      | isDoesNotExistError e = do
          createDirectoryIfMissing True $ takeDirectory idFile
          instanceId <- UUID.nextRandom
          LBS.writeFile idFile $ UUID.toByteString instanceId
          return instanceId
      | otherwise = throw e

createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool
createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
  logFunc <- askLoggerIO
  let
    withLogging :: LoggingT IO a -> IO a
    withLogging = flip runLoggingT logFunc

    mkConnection = withLogging $ do
      $logInfoS "SMTP" "Opening new connection"
      liftIO mkConnection'
    mkConnection'
      | SmtpSslNone <- smtpSsl = connectSMTPPort smtpHost smtpPort
      | SmtpSslSmtps <- smtpSsl = connectSMTPSSLWithSettings smtpHost $ defaultSettingsWithPort smtpPort
      | SmtpSslStarttls <- smtpSsl = connectSMTPSTARTTLSWithSettings smtpHost $ defaultSettingsWithPort smtpPort
    reapConnection conn = withLogging $ do
      $logDebugS "SMTP" "Closing connection"
      liftIO $ closeSMTP conn
    applyAuth :: SmtpAuthConf -> SMTPConnection -> IO SMTPConnection
    applyAuth SmtpAuthConf{..} conn = withLogging $ do
      $logDebugS "SMTP" "Doing authentication"
      authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn
      unless authSuccess $
        fail "SMTP authentication failed"
      return conn
  liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit

createWidgetMemcached :: (MonadLogger m, MonadResource m) => WidgetMemcachedConf -> m Memcached.Connection
createWidgetMemcached WidgetMemcachedConf{widgetMemcachedConnectInfo} = snd <$> allocate (Memcached.connect widgetMemcachedConnectInfo) Memcached.close

-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: MonadIO m => UniWorX -> m Application
makeApplication foundation = liftIO $ do
    logWare <- makeLogWare foundation
    -- Create the WAI application and apply middlewares
    appPlain <- toWaiAppPlain foundation
    return $ logWare $ defaultMiddlewaresNoLogging appPlain

makeLogWare :: MonadIO m => UniWorX -> m Middleware
makeLogWare app = do
  logWareMap <- liftIO $ newTVarIO HashMap.empty

  let
    mkLogWare ls@LogSettings{..} = do
      logger <- readTVarIO . snd $ appLogger app
      logWare <- mkRequestLogger def
        { outputFormat = bool
            (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader)
            (Detailed True)
            logDetailed
        , destination = Logger $ loggerSet logger
        }
      atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare
      return logWare

  void. liftIO $
    mkLogWare =<< readTVarIO (appLogSettings app)

  return $ \wai req fin -> do
    lookupRes <- atomically $ do
      ls <- readTVar $ appLogSettings app
      existing <- HashMap.lookup ls <$> readTVar logWareMap
      return $ maybe (Left ls) Right existing
    logWare <- either mkLogWare return lookupRes
    logWare wai req fin

-- | Warp settings for the given foundation value.
warpSettings :: UniWorX -> Settings
warpSettings foundation = defaultSettings
    & setBeforeMainLoop (runAppLoggingT foundation $ do
                            let notifyReady = do
                                  $logInfoS "setup" "Ready"
                                  void $ liftIO Systemd.notifyReady
                            if
                              | foundation ^. _appHealthCheckDelayNotify
                                -> void . fork $ do
                                  atomically $ readTVar (foundation ^. _appHealthReport) >>= guard . maybe False ((== HealthSuccess) . classifyHealthReport . snd)
                                  notifyReady
                              | otherwise
                                -> notifyReady
                        )
    & setHost (foundation ^. _appHost)
    & setPort (foundation ^. _appPort)
    & setOnException (\_req e ->
        when (defaultShouldDisplayException e) $ do
          logger <- readTVarIO . snd $ appLogger foundation
          messageLoggerSource
            foundation
            logger
            $(qLocation >>= liftLoc)
            "yesod"
            LevelError
            (toLogStr $ "Exception from Warp: " ++ show e)
                     )
                           

getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv

adjustSettings :: MonadIO m => AppSettings -> m AppSettings
adjustSettings = execStateT $ do
  watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
  watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
  myProcessID <- liftIO getProcessID
  case watchdogMicroSec of
    Just wInterval
      | maybe True (== myProcessID) watchdogProcess
        -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2)
    _other -> return ()

-- | main function for use by yesod devel
develMain :: IO ()
develMain = runResourceT $ do
  settings <- getAppDevSettings
  foundation <- makeFoundation settings
  wsettings <- liftIO . getDevSettings $ warpSettings foundation
  app <- makeApplication foundation

  handleJobs foundation
  liftIO . develMainHelper $ return (wsettings, app)

-- | The @main@ function for an executable running this site.
appMain :: MonadResourceBase m => m ()
appMain = runResourceT $ do
    settings <- getAppSettings

    -- Generate the foundation from the settings
    foundation <- makeFoundation settings

    runAppLoggingT foundation $ do
      $logDebugS "setup" "Job-Handling"
      handleJobs foundation

      -- Generate a WAI Application from the foundation
      app <- makeApplication foundation

      -- Run the application with Warp
      activatedSockets <- liftIO Systemd.getActivatedSocketsWithNames
      sockets <- case activatedSockets of
        Just socks
          | not $ null socks -> do
            $logInfoS "bind" [st|Ignoring configuration and listening on #{intercalate ", " (fmap (tshow . snd) socks)}|]
            return $ fst <$> socks
        _other -> do
          let
            host = foundation ^. _appHost
            port = foundation ^. _appPort
          $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|]
          liftIO $ pure <$> bindPortTCP port host

      $logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets

      mainThreadId <- myThreadId
      liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do
        $logInfoS "shutdown" [st|Received signal #{tshow siginfoSignal}|]
        didStore <- runMaybeT . forM_ sockets $ MaybeT . liftIO . Systemd.storeFd
        case didStore of
          Just () -> $logInfoS "shutdown" "Stored all bound sockets for restart"
          Nothing -> forM_ sockets $ liftIO . Socket.close
        liftIO . throwTo mainThreadId . ExitFailure $ 0b10000000 + fromIntegral siginfoSignal

      let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
      case sockets of
        []  -> $logErrorS "bind" "No sockets to listen on"
        [s] -> liftIO $ runWarp s
        ss  -> liftIO $ void . waitAnyCancel =<< mapM (async . runWarp) ss


--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
foundationStoreNum :: Word32
foundationStoreNum = 2

getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application)
getApplicationRepl = do
    settings <- getAppDevSettings
    foundation <- makeFoundation settings
    handleJobs foundation
    wsettings <- liftIO . getDevSettings $ warpSettings foundation
    app1 <- makeApplication foundation

    let foundationStore = Store foundationStoreNum
    liftIO $ deleteStore foundationStore
    liftIO $ writeStore foundationStore foundation

    return (getPort wsettings, foundation, app1)

shutdownApp :: MonadIO m => UniWorX -> m ()
shutdownApp app = do
  stopJobCtl app
  liftIO $ do
    for_ (appWidgetMemcached app) Memcached.close
    for_ (appSmtpPool app) destroyAllResources
    destroyAllResources $ appConnPool app
  release . fst $ appLogger app


---------------------------------------------
-- Functions for use in development with GHCi
---------------------------------------------

-- | Run a handler
handler :: Handler a -> IO a
handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h

-- | Run DB queries
db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
db = handler . runDB

addPWEntry :: User
           -> Text {-^ Password -}
           -> IO ()
addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do
  PWHashConf{..} <- getsYesod $ view _appAuthPWHash
  (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
  void $ insert User{..}