{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
module Base.Context where

import           Base.Event
import           Base.Exception
import           Base.Import
import           Base.Logger
import           Base.Prop

import           Control.Concurrent        (ThreadId)
import qualified Control.Concurrent.Map    as M
import           Control.Monad.Trans.State
import qualified Data.Cache                as C
import           Data.Dynamic
import           Data.Functor.Identity     (Identity (..))
import qualified Data.Map                  as Map
import           Data.Proxy
import           Data.Swagger              hiding (get)
import           Database.Persist.TH
import           Text.Read                 (readMaybe)
import           Web.HttpApiData

data RoleType = RoleUser
              | RoleAdmin
              deriving (Eq,Show,Read,Generic,ToSchema,FromJSON,ToJSON)
derivePersistField "RoleType"

data TokenType = TokenUser
               | TokenAdmin
               | Ticket
               deriving (Eq,Show,Read,Generic,ToSchema,FromJSON,ToJSON)

data TicketType = TicketUserInfo
                deriving (Eq,Show,Read,Generic,ToParamSchema,ToSchema,FromJSON,ToJSON)

instance FromHttpApiData TicketType where
  parseQueryParam v = maybeToEither ("Param " <> v <> " in valid") $ readMaybe $ cs v

validTime :: (Num a) => TokenType -> a
validTime TokenUser  = 3600 * 24
validTime TokenAdmin = 3600
validTime Ticket     = 600

-- Determine token has with permission
hasAuth :: Token -> TokenType -> Bool
hasAuth token auth = let userAuth = tokenType token
                     in  userAuth == TokenAdmin || userAuth == auth

isOnce :: TokenType -> Bool
isOnce = (== Ticket)

-- Determine which role can sign which permission
canSign :: TokenType -> RoleType -> Bool
canSign want role = role == RoleAdmin || want == TokenUser

data Token = Token
   { tokenId            :: Text
   , tokenType          :: TokenType
   , tokenClaims        :: [TicketType]
   , tokenUser          :: ID
   , tokenSecret        :: Text
   , tokenRefreshSecret :: Text
   } deriving (Eq,Show)

type TokenCache   = C.Cache Text Token
type JobMap       = Map.Map ThreadId Text
type ExtensionMap = M.Map Text Dynamic

data BaseContext = BaseContext
  { baseConnection :: BaseConnection
  , baseTokenCache :: TokenCache
  , baseJobs       :: JobMap
  , baseExtension  :: ExtensionMap
  , basePropSource :: PropertySource
  , baseLogger     :: LogContext
  }

extensionLockKey :: Text
extensionLockKey = "Extension.Lock"

getExtension :: (MonadIO m, MonadThrow m, Typeable a) => Text -> AppM m a
getExtension key = gets baseExtension >>= liftIO . M.lookup key >>= get . (fromDynamic =<<)
  where get Nothing  = throwM $ ServiceException_ $ key <> " not loaded"
        get (Just r) = return r

tryExtension :: (MonadIO m, MonadThrow m, Typeable a) => a -> Text -> AppM m a
tryExtension a key = (fromMaybe a . (fromDynamic =<<)) <$> (gets baseExtension >>= liftIO . M.lookup key)

setExtension :: (MonadIO m, MonadThrow m, Typeable a) => Text -> a -> AppM m ()
setExtension key a = do
  checkLock
  when (extensionLockKey /= key)
    (debugLn $ "Register extension <<" <> key <> ">>")
  void $ gets baseExtension >>= liftIO . M.insert key (toDyn a)

checkLock :: (MonadIO m, MonadThrow m) => AppM m ()
checkLock = tryExtension False extensionLockKey >>= go
  where go True = throwM ExtensionModificationRejectedException
        go _    = return ()

lockExtenstion :: (MonadIO m, MonadThrow m)  => AppM m ()
lockExtenstion = setExtension extensionLockKey True

type AppM = StateT BaseContext

instance (MonadIO m) => MonadLogger (AppM m) where
  getLogContext = baseLogger <$> get

instance (MonadIO m, MonadThrow m) => MonadEvent (AppM m) where
  getEventConsumer proxy = tryExtension [] $ "Event." <> cs (eventKey proxy)

instance (MonadThrow m) => MonadProperty (AppM m) where
  propertySources = basePropSource <$> get

addEventHandler :: (MonadIO m, MonadThrow m, Event e) => Proxy e -> (e -> AppM IO ()) -> AppM m ()
addEventHandler p = addEventHandler' p Nothing

addEventHandler' :: (MonadIO m, MonadThrow m, Event e) => Proxy e -> Maybe Text -> (e -> AppM IO ()) -> AppM m ()
addEventHandler' p hname h = do
  hs      <- getEventConsumer p
  context <- get
  let key  = "Event." <> cs (eventKey p)
      h'   = runAppM context . h
      name = fromMaybe (key <> "." <> showText (length hs + 1)) hname
  infoLn $ "Register eventHandler " <> name <> " for " <> key
  setExtension key (h':hs)

defaultBaseContext :: IO BaseContext
defaultBaseContext = do
  cache <- C.newCache Nothing    :: IO TokenCache
  eMap  <- M.empty
  BaseContext (Nothing,Nothing) cache Map.empty eMap emptyPropertySource <$> stdoutLog

runAppM :: (Monad m) => BaseContext -> AppM m a -> m a
runAppM = flip evalStateT

evalPropOrDefault :: FromJSON a => a -> BaseContext -> Text -> a
evalPropOrDefault d c key = fromMaybe d $ evalProp c key

evalProp :: FromJSON a => BaseContext -> Text -> Maybe a
evalProp c key = runIdentity $ runProp (snd $ basePropSource c) $ getProp key
