{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

{-|
Module      : Web.Lightning
Description : lightning-viz REST API wrapper.
Copyright   : (c) Connor Moreside, 2016
License     : BSD-3
Maintainer  : connor@moresi.de
Stability   : experimental
Portability : POSIX
-}

module Web.Lightning
  (
    -- * Lightning Types
    LoginMethod(..)
  , LightningOptions(..)
  , LightningState(..)
    -- * Execute
  , runLightning
  , runLightningWith
  , runResumeLightningtWith
  , interpretIO
  -- * Client configuration
  , defaultLightningOptions
  , setBaseURL
  , setSessionName
  , setSessionId
  , setBasicAuth
  -- * Re-exports
  , APIError(..)
  , module Web.Lightning.Types.Error
  , module Web.Lightning.Types.Lightning
  )
  where

--------------------------------------------------------------------------------
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Free
import           Control.Monad.Trans.Reader

import           Data.Aeson
import qualified Data.ByteString               as B
import           Data.Default.Class
import qualified Data.Text                     as T

import           Web.Lightning.Session
import           Web.Lightning.Types.Error
import           Web.Lightning.Types.Lightning
import           Web.Lightning.Utilities

import           Network.HTTP.Client
import           Network.HTTP.Client.TLS

import           Network.API.Builder           as API
--------------------------------------------------------------------------------

-- | Represents the different authentication mechanisms available in
-- the lightning-viz server.
data LoginMethod = Anonymous -- ^ No authentication required
                 | BasicAuth Credentials -- ^ HTTP Basic Authentication
                 deriving (Show)

{- | Username and password pair for authenticating to the lightning-viz server. -}
type Credentials = (B.ByteString, B.ByteString)

instance Default LoginMethod where
  def = Anonymous

-- | Defines the available options for running a lightning action(s).
data LightningOptions =
  LightningOptions { optConnManager :: Maybe Manager
                     -- ^ Re-usable connection manager used during Lightning
                     -- session.
                   , optHostUrl     :: T.Text
                     -- ^ The base lightning-viz server url.
                   , optLoginMethod :: LoginMethod
                     -- ^ The authentication mechanism used to communicate
                     -- with the lightning-viz server.
                   , optSession     :: Maybe Session
                     -- ^ Defines what session to use when creating viaualizations
                     -- on the lightning-viz server. If no session is specified,
                     -- one will be created automatically.
                   }

instance Default LightningOptions where
  def = LightningOptions Nothing defaultBaseURL Anonymous Nothing

-- | Defines the default lightning-viz options.
defaultLightningOptions :: LightningOptions
defaultLightningOptions = def

-- | Sets the base URL of Lightning's API in the given
-- 'LightningOptions' record.
setBaseURL :: T.Text
           -- ^ Fully qualified API base URL
           -> LightningOptions
           -> LightningOptions
setBaseURL url opts = opts { optHostUrl = url }

-- | Sets the name of the session that is nested in the
-- given 'LightningOptions' record.
setSessionName :: T.Text
                  -- ^ The new session name
               -> LightningOptions
               -> LightningOptions
setSessionName n opts@(LightningOptions _ _ _ s) =
  opts { optSession = Just sess }
  where
    sess =
      case s of
        Nothing -> def { snName = Just n }
        Just s' -> s' { snName = Just n }

-- | Sets the session ID of the session nested in the given
-- 'LightningOptions' record.
setSessionId :: T.Text
                -- ^ The new session ID
             -> LightningOptions
             -> LightningOptions
setSessionId i opts@(LightningOptions _ _ _ s) =
  opts { optSession = Just sess }
  where
    sess =
      case s of
        Nothing -> def { snId = i }
        Just s' -> s' { snId = i }

-- | Sets 'BasicAuth' with 'Credentials' as the login method in the
-- given 'LightningOptions' record.
setBasicAuth :: Credentials -> LightningOptions -> LightningOptions
setBasicAuth creds opts = opts { optLoginMethod = BasicAuth creds }

-- | Performs a lightning action (or 'LightningT' transformer actions) with the
-- default lightning options. By default, the lightning-viz server is assumed to
-- be running on http://localhost:3000 and a new session will be created.
runLightning :: MonadIO m
             => LightningT m a
             -> m (Either (APIError LightningError) a)
runLightning = runLightningWith defaultLightningOptions

-- | Performs a lightning action (or 'LightningT' transformer actions) with
-- the specified lightning options.
runLightningWith :: MonadIO m => LightningOptions
                     -> LightningT m a
                     -> m (Either (APIError LightningError) a)
runLightningWith opts lightning =
  dropResume <$> runResumeLightningtWith opts lightning

-- | Runs a specified series of lightning actions.
interpretIO :: MonadIO m => LightningState
                -> LightningT m a
                -> m (Either (APIError LightningError, Maybe (LightningT m a)) a)
interpretIO lstate@(LightningState url _ _ _) (LightningT r) =
  runFreeT (runReaderT r url) >>= \case
    Pure x -> return $ Right x
    Free (WithBaseURL u x n) ->
      interpretIO (lstate { stCurrentBaseURL = u }) x >>= \case
        Left (err, Just resume) ->
          return $ Left (err, Just $ resume >>= LightningT . liftLightningF . n)
        Left (err, Nothing) -> return $ Left (err, Nothing)
        Right res -> interpretIO lstate $ LightningT $ (liftLightningF . n) res
    Free (FailWith x) -> return $ Left (x, Nothing)
    Free (RunRoute route n) ->
      interpretIO lstate $ LightningT $ wrap $ ReceiveRoute route (liftLightningF . n . unwrapJSON)
    Free (SendJSON jsonObj route n) ->
      handleSendJSON route lstate jsonObj >>= \case
        Left err -> return $ Left (err, Just $ LightningT $ wrap $ SendJSON jsonObj route (liftLightningF . n))
        Right x -> interpretIO lstate $ LightningT $ (liftLightningF . n) x
    Free (ReceiveRoute route n) ->
      handleReceive route lstate >>= \case
        Left err -> return $ Left (err, Just $ LightningT $ wrap $ ReceiveRoute route (liftLightningF . n))
        Right x -> interpretIO lstate $ LightningT $ (liftLightningF . n) x

-- | Runs a lightning action using the specified options.
runResumeLightningtWith :: MonadIO m => LightningOptions
                            -> LightningT m a
                            -> m (Either (APIError LightningError, Maybe (LightningT m a)) a)
runResumeLightningtWith (LightningOptions cm hu lm s) lightning = do
  manager <- case cm of
    Just m  -> return m
    Nothing -> liftIO $ newManager tlsManagerSettings
  auth <- case lm of
    Anonymous       -> return id
    BasicAuth creds -> return $ uncurry applyBasicAuth creds
  session <- case s of
    Just s' ->
      case snId s' of
        "" -> (fmap . fmap) Just $
          interpretIO (LightningState hu manager Nothing auth) $ createSession $ snName s'
        _ -> return $ Right $ Just s'
    Nothing -> (fmap . fmap) Just $
      interpretIO (LightningState hu manager Nothing auth) $ createSession Nothing
  case session of
    Left (err, _) -> return $ Left (err, Just lightning)
    Right s' ->
      interpretIO (LightningState hu manager s' auth) lightning

-- | Runs the specified route using the current state.
handleReceive :: (MonadIO m, Receivable a) => Route
                    -> LightningState
                    -> m (Either (APIError LightningError) a)
handleReceive r lstate = do
  (res, _, _) <- runAPI (builderFromState lstate) (stConnManager lstate) () $
    API.runRoute r

  return res

-- | Runs the specified route and sends the specified JSON value as the the
-- request body.
handleSendJSON :: (MonadIO m, Receivable a) => Route
                    -> LightningState
                    -> Value
                    -> m (Either (APIError LightningError) a)
handleSendJSON r lstate p = do
  (res, _, _) <- runAPI (builderFromState lstate) (stConnManager lstate) () $
    API.sendRoute p r

  return res

-- | Creates a 'Builder' record to keep track of the lightning-viz server's
-- name and base URL.
builderFromState :: LightningState
                 -> Builder
builderFromState (LightningState hurl _ (Just s) auth) =
  Builder "Lightning" (addSessionId hurl (snId s)) id auth
builderFromState (LightningState hurl _ Nothing auth) =
  Builder "Lightning" hurl id auth

-- | Unwraps the response from interpretIO.
dropResume :: Either (APIError LightningError, Maybe (LightningT m a)) a
                    -> Either (APIError LightningError) a
dropResume (Left (x, _)) = Left x
dropResume (Right x)     = Right x

-- | Stores the current state of the lightning transformer stack.
data LightningState =
  LightningState { stCurrentBaseURL :: T.Text
                   -- ^ Current base URL of the lightning-viz server.
                 , stConnManager    :: Manager
                   -- ^ Current connection manager used to run actions.
                 , stSession        :: Maybe Session
                   -- ^ The current lightning session to run actions against.
                 , stApplyAuth      :: Request -> Request
                   -- ^ Hook to add auth credentials on performing a request
                   -- to the lightning-viz sever.
                 }