{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications #-}

module Server
( insecureOAuthMock'
, runMockServer
, runMockServer'
) where

import AuthCode
import User

import Control.Applicative ((<|>))
import Control.Concurrent
import Control.Concurrent.STM.TVar (newTVarIO)
import Control.Exception (bracket)
import Control.Monad (unless)
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader

import Data.Aeson
import Data.ByteString (ByteString (..))
import Data.List (find, elemIndex)
import Data.Maybe (fromMaybe, isJust)
import Data.String (IsString (..))
import Data.Text hiding (elem, find, head, length, map, null, splitAt, tail, words)
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (NominalDiffTime (..), nominalDay)

import qualified Data.Map.Strict as Map

import Network.HTTP.Client (newManager, defaultManagerSettings)
import Network.Wai.Handler.Warp

import Servant
import Servant.Client
import Servant.API

import Text.ParserCombinators.ReadPrec (look)
import Text.Read (readPrec)


testUsers :: [User] -- TODO move to db
testUsers =
  [ User {name = "Fallback User", email = "foo@bar.com", password = "0000", uID = "0"}
  , User {name = "Tina Tester", email = "t@t.tt", password = "1111", uID = "1"}
  , User {name = "Max Muster", email = "m@m.mm", password = "2222", uID = "2"}]

data AuthClient = Client
  { ident :: Text
  , secret :: Text
  } deriving (Show, Eq)

trustedClients :: [AuthClient] -- TODO move to db
trustedClients = [Client "42" "shhh"]

data ResponseType = Code -- ^ authorisation code grant
                  | Token -- ^ implicit grant via access token
                  | IDToken -- ^ implicit grant via access token & ID token
                  deriving (Eq, Show)
instance Read ResponseType where
  readPrec = look >>= \str -> return $ case str of
    "code" -> Code
    "token" -> Token
    "id_token" -> IDToken

type QScope    = String
type QClient   = String
type QResType  = String
type QRedirect = String

type QParam = QueryParam' [Required, Strict]

type Auth user userData = BasicAuth "login" user
                       :> "auth"
                       :> QParam "scope" QScope
                       :> QParam "client_id" QClient
                       :> QParam "response_type" QResType
                       :> QParam "redirect_uri" QRedirect
                       :> Get '[JSON] userData

-- type Insert = "insert" :> Post '[JSON] User


type AuthHandler = ReaderT AuthState Handler
type AuthServer a = ServerT a AuthHandler

toHandler :: AuthState -> AuthHandler a -> Handler a
toHandler s h = runReaderT h s

authServer :: forall user userData . UserData user userData => AuthServer (Auth user userData)
authServer = handleAuth
  where
    handleAuth :: user
               -> QScope
               -> QClient
               -> QResType
               -> QRedirect
               -> AuthHandler userData
    handleAuth u scopes client responseType url = do
      unless (isJust $ find (\c -> ident c == pack client) trustedClients) . -- TODO fetch trusted clients from db | TODO also check if the redirect url really belongs to the client
        throwError $ err404 { errBody = "Not a trusted client."}
      let
        scopes' = map (readScope @user @userData) $ words scopes
        uData = mconcat $ map (userScope @user @userData u) scopes'
        responseType' = read @ResponseType responseType
      mAuthCode <- asks (genUnencryptedCode client url 600) >>= liftIO
      liftIO $ print mAuthCode
      liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
      -- return uData
      redirect $ url `withCode` mAuthCode
    redirect :: Maybe ByteString -> AuthHandler userData
    redirect (Just url) = throwError err303 { errHeaders = [("Location", url)]}
    redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
    withCode :: String -> Maybe String -> Maybe ByteString
    withCode url Nothing = Nothing
    withCode url (Just code) =
      let qPos = fromMaybe (length url) $ elemIndex '?' url
          (pre, post) = splitAt qPos url
          post' = if not (null post) then '&' : tail post else post
      in Just . fromString $ pre ++ "?authorization_code=" ++ code ++ post'


exampleAuthServer :: AuthServer (Auth User (Map.Map Text Text))
exampleAuthServer = authServer

authAPI :: Proxy (Auth User (Map.Map Text Text))
authAPI = Proxy

-- insecureOAuthMock :: Application
-- insecureOAuthMock = authAPI `serve` exampleAuthServer

insecureOAuthMock' :: [User] -> AuthState -> Application
insecureOAuthMock' testUsers s = serveWithContext authAPI c $ hoistServerWithContext authAPI p (toHandler s) exampleAuthServer
  where
    c = authenticate testUsers :. EmptyContext
    p = Proxy :: Proxy '[BasicAuthCheck User]

authenticate :: [User] -> BasicAuthCheck User
authenticate users = BasicAuthCheck $ \authData -> do
  let
    (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData
  case (find (\u -> email u == uEmail) users) of
    Nothing -> return NoSuchUser
    Just u  -> return $ if uPass == password u then Authorized u else BadPassword

frontend :: BasicAuthData -> ClientM (Map.Map Text Text)
frontend ba = client authAPI ba "[ID]" "42" "code" ""

runMockServer :: Int -> IO ()
runMockServer port = do
  state <- newTVarIO $ State { activeCodes = Map.empty }
  run port $ insecureOAuthMock' testUsers state

runMockServer' :: Int -> IO ()
runMockServer' port = do
  mgr <- newManager defaultManagerSettings
  state <- newTVarIO $ State { activeCodes = Map.empty }
  bracket (forkIO . run port $ insecureOAuthMock' testUsers state) killThread $ \_ ->
    runClientM (frontend $ BasicAuthData "foo@bar.com" "0000") (mkClientEnv mgr (BaseUrl Http "localhost" port ""))
      >>= print


------
------ Token
------


data ClientData = ClientData
  { grantType :: GrantType
  , grant :: String
  , userName :: Maybe String
  , clientID :: String
  , clientSecret :: String
  , redirect :: String
  } deriving Show

instance FromJSON ClientData where
  parseJSON (Object o) = ClientData
    <$> o .:  "grant_type"
    <*>  (o .: ps PassCreds --TODO add alternatives
      <|> o .: ps AuthCode
      <|> o .: ps Implicit
      <|> o .: ps ClientCreds)
    <*> o .:? "username"
    <*> o .:  "client_id"
    <*> o .:  "client_secret"
    <*> o .:  "redirect_url"
      where ps = fromString @Key . show

data GrantType = PassCreds | AuthCode | Implicit | ClientCreds deriving (Eq)

instance Show GrantType where
  show PassCreds = "password"
  show AuthCode  = "authorization_code"
  show _         = undefined --TODO support other flows

instance FromJSON GrantType where
  parseJSON (String s)
    | s == pack (show AuthCode) = pure AuthCode
    | otherwise = error $ show s ++ " grant type not supported yet"

data JWT = JWT
  { token :: Text -- TODO should be JWT
  , tokenType :: Text -- TODO enum
  , expiration :: NominalDiffTime
  }

type Token = "token"
          :> ReqBody '[JSON] ClientData
          :> Post '[JSON] JWT

tokenEndpoint :: AuthServer Token
tokenEndpoint = provideToken
  where
    provideToken :: ClientData -> AuthHandler JWT
    provideToken client = case (grantType client) of
      AuthCode -> do
        --TODO validate everything
        unless (Client (pack $ clientID client) (pack $ clientSecret client) `elem` trustedClients) .
          throwError $ err500 { errBody = "Invalid client" }
        valid <- asks (verify (grant client) (clientID client)) >>= liftIO
        unless valid . throwError $ err500 { errBody = "Invalid authorisation code" }
        return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
      x -> error $ show x ++ " not supported yet"