mateamt/app/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where

import Prelude as P

import Servant
import Servant.Server.Experimental.Auth

import Data.Set as S (empty)
import qualified Data.Map.Lazy as M
import Data.ByteString.Lazy as BL hiding (putStrLn)
import Data.ByteString.Char8 as B8 hiding (putStrLn)
import qualified Data.Text as T
import Data.String
import Data.YAML
import Data.Version (showVersion)
import Data.CaseInsensitive  (CI)
import qualified Data.CaseInsensitive as CI
import Data.IP

import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.Migration
import Database.PostgreSQL.Simple.Util

import Network.Wai
import Network.Wai.Logger
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.Throttle
import Network.Socket (SockAddr(..), defaultPort)

import Control.Monad.Reader

import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar

import Options.Applicative

import System.Clock (TimeSpec(..))

-- internal imports

import API
import Model as M

import AppTypes
import Types
import Control
import Janitor
-- import Middleware

import Paths_mateamt (version)

main :: IO ()
main = do
  (Options confLoc) <- execParser opts
  raw <- BL.readFile (T.unpack confLoc)
  case decode1 raw of
    Left (loc, msg) ->
      error (T.unpack $ confLoc <> ":" <>
        fromString (prettyPosWithSource loc raw " error") <>
        fromString msg
        )
    Right
      (ServerConfig
        db_host
        db_port
        db_name
        db_user
        db_passwd
        sym
        lport
        lhost
        -- max_conn_per_client
        block_registration
        ) -> do
          conn <- connectPostgreSQL (
            "host='" <> fromString (T.unpack db_host) <> "' " <>
            "port=" <> fromString (show db_port) <> " " <>
            "dbname='" <> fromString (T.unpack db_name) <> "' " <>
            "user='" <> fromString (T.unpack db_user) <> "' " <>
            "password='" <> fromString (T.unpack db_passwd) <> "'"
            )
          store <- newTVarIO S.empty
          -- tracker <- newTVarIO M.empty
          migrationsExist <- existsTable conn "schema_migrations"
          when (not migrationsExist) $ do
            withTransaction conn $
              void $ do
                runMigration $
                  MigrationContext MigrationInitialization True conn
                execute_ conn initAvatar
                execute_ conn initUser
                execute_ conn initProduct
                execute_ conn initToken
                execute_ conn initAuthData
                execute_ conn initAmount
                execute_ conn initJournal
                execute_ conn initRole
                execute_ conn initUserToRole
                runInsertInitialRole
          -- TODO: check for Migrations
          forkCleanProcess conn store
          withStdoutLogger $ \ilog -> do
            let settings = setPort (fromIntegral lport) $
                  setHost (fromString $ T.unpack lhost) $
                  -- setOnOpen (addToTracker tracker max_conn_per_client) $
                  -- setOnClose (removeFromTracker tracker) $
                  setLogger ilog defaultSettings
                initState = ReadState
                  { rsConnection  = conn
                  , rsTicketStore = store
                  , rsCurrencySymbol = sym
                  , rsSoftwareVersion = T.pack (showVersion version)
                  }
                expirationSpec = TimeSpec 5 0 -- five seconds
            th <- initCustomThrottler (defaultThrottleSettings expirationSpec)
              (\req ->
                let headers = requestHeaders req
                in  case lookup "x-forwarded-for" headers of
                      Just addrs ->
                        let addr = fst (B8.break (== ',') addrs)
                        in  Right $ Address $ toSockAddr (read (B8.unpack addr), defaultPort)
                      Nothing -> Right $ Address $ remoteHost req
                )
            runSettings settings (throttle th (app block_registration initState))
  where
    opts = info (options <**> helper)
      ( fullDesc
        <> progDesc "Run the \"mateamt\" API-Server."
        <> header "mateamt - Your friendly mate distribution office"
        )

app :: Bool -> ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
app block_registration initState =
  serveWithContext mateApi (genAuthServerContext (rsConnection initState)) $
    hoistServerWithContext
      mateApi
      authProxy
      (`runReaderT` initState)
      ( authGet :<|>
        authSend :<|>
        authLogout :<|>

        authManageList :<|>
        authManageNewAuth :<|>
        authManageDeleteAuth :<|>

        (
        if block_registration
        then
          const $ throwError $ err406
            { errBody = "User registration is not allowed."
            }
        else
          userNew
        ) :<|>
        userGet :<|>
        userUpdate :<|>
        userList :<|>
        userRecharge :<|>
        userTransfer :<|>

        productNew :<|>
        productOverview :<|>
        productStockRefill :<|>
        productStockUpdate :<|>
        productList :<|>
        productShortList :<|>

        buy :<|>

        journalShow :<|>
        journalCheck :<|>

        avatarGet :<|>
        avatarInsert :<|>
        avatarUpdate :<|>
        avatarList :<|>

        metaGet
      )

mateApi :: Proxy MateAPI
mateApi = Proxy

authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
authProxy = Proxy

genAuthServerContext
  :: Connection
  -> Context '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
genAuthServerContext conn = authHandler conn Servant.:. EmptyContext

type instance AuthServerData (AuthProtect "header-auth") = Maybe (Int, AuthMethod)

authHandler :: Connection -> AuthHandler Request (Maybe (Int, AuthMethod))
authHandler conn = mkAuthHandler handler
  where
    handler :: Request -> Handler (Maybe (Int, AuthMethod))
    handler req = do
      let headers = requestHeaders req
      case lookup "Authentication" headers of
        Just hh ->
          validateToken hh conn
        _       ->
          return Nothing