{-# LANGUAGE OverloadedStrings #-}

module Apps.Juno.ApiHandlers
  ( createAccount
  , adjustAccount
  , transactAPI
  , ledgerQueryAPI
  , cmdBatch
  , apiRoutes
  , ApiEnv(..)
  ) where

import Control.Concurrent.Chan.Unagi
import Control.Concurrent.MVar (readMVar)
import Control.Concurrent.Lifted (threadDelay)
import Control.Lens hiding ((.=))
import Control.Monad.Reader
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Text as T
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Monoid ((<>))
import Data.Text.Encoding (decodeUtf8)
import Data.Ratio
import Data.Aeson (encode, object, (.=))
import qualified Data.Aeson as JSON
import Snap.Core
import System.Posix.Files

import Apps.Juno.JsonTypes
import Apps.Juno.Ledger
import Apps.Juno.Parser
import Juno.Types hiding (CommandBatch)
import Schwifty.Swift.M105.Types
import Schwifty.Swift.M105.Parser
import Apps.Juno.ApiDemoHandler (transferDemoReqHandler)

data ApiEnv = ApiEnv {
      _aiToCommands :: InChan (RequestId, [CommandEntry]),
      _aiCmdStatusMap :: CommandMVarMap
}

apiRoutes :: ReaderT ApiEnv Snap ()
apiRoutes = route [
              ("api/juno/v1/accounts/create", createAccount)
             ,("api/juno/v1/accounts/adjust", adjustAccount)
             ,("api/juno/v1/transact", transactAPI)
             ,("api/juno/v1/query", ledgerQueryAPI)
             ,("api/juno/v1/cmd/batch", cmdBatch)
             ,("api/juno/v1/poll", pollForResults)
              -- original API
             ,("hopper", hopperHandler)
             ,("swift", swiftHandler)
             ,("api/swift-submit", swiftSubmission)
             ,("api/ledger-query", ledgerQuery)
              -- demo endpoints
             ,("api/juno/v1/transfer", apiWrapper transferDemoReqHandler)
            ,("ui",serveUI)
             ]

serveUI :: MonadSnap m => m ()
serveUI = do
  p <- (("demoui/public/"++) . BSC.unpack . rqPathInfo) <$> getRequest
  e <- liftIO $ fileExist p
  if e then sendFile p else withResponse $ \r -> do
            writeBS "Error 404: Not Found"
            liftIO $ putStrLn $ "Error 404: Not Found: " ++ p
            finishWith (setResponseStatus 404 "Not Found" r)


apiWrapper :: (BLC.ByteString -> Either BLC.ByteString [CommandEntry]) -> ReaderT ApiEnv Snap ()
apiWrapper requestHandler = do
   modifyResponse $ setHeader "Content-Type" "application/json"
   reqBytes <- (readRequestBody 1000000)
   case requestHandler reqBytes of
     Right cmdEntries -> do
         env <- ask
         reqestId@(RequestId rId) <- liftIO $ setNextCmdRequestId (_aiCmdStatusMap env)
         liftIO $ writeChan (_aiToCommands env) (reqestId, cmdEntries)
         (writeBS . BLC.toStrict . JSON.encode) $ commandResponseSuccess ((T.pack . show) rId) ""
     Left err -> writeBS $ BLC.toStrict err

-- create an account returns cmdId see: juno/jmeter/juno_API_jmeter_test.jmx
createAccount :: ReaderT ApiEnv Snap ()
createAccount = apiWrapper createAccountReqHandler

-- Adjusts Account (negative, positive) returns cmdIds: juno/jmeter/juno_API_jmeter_test.jmx
adjustAccount :: ReaderT ApiEnv Snap ()
adjustAccount = apiWrapper adjustAccoutReqHandler

-- juno/jmeter/juno_API_jmeter_test.jmx
-- accept hopercommands transfer(000->100->101->102->103->003, 100%1)
transactAPI :: ReaderT ApiEnv Snap ()
transactAPI = apiWrapper transactReqHandler

ledgerQueryAPI :: ReaderT ApiEnv Snap ()
ledgerQueryAPI = apiWrapper ledgerQueryReqHandler

-- receives a list of commands
-- {"payload":{"cmds": ["{\"account\":\"WATER\"}", "{\"account\":\"TSLA\"}"},"digest":{"hash":"hashy","key":"mykey"}}
cmdBatch :: ReaderT ApiEnv Snap ()
cmdBatch = apiWrapper cmdBatchHandler


-- | Handlers to deal with the incomming request bytes and either create the correct
--   [ComandEntry] ByteString or the JSON error message ByteString
createAccountReqHandler :: BLC.ByteString -> Either BLC.ByteString [CommandEntry]
createAccountReqHandler bs =
    case JSON.decode bs of
      Just (CreateAccountRequest (AccountPayload acct) _) ->
          Right [CommandEntry $ createAccountBS' $ T.unpack acct]
      Nothing ->
          Left $ JSON.encode $ commandResponseFailure "" "Malformed input, could not decode input JSON."
  where
    createAccountBS' acct = BSC.pack $ "CreateAccount " ++ acct

adjustAccoutReqHandler :: BLC.ByteString -> Either BLC.ByteString [CommandEntry]
adjustAccoutReqHandler bs =
    case JSON.decode bs of
        Just (AccountAdjustRequest (AccountAdjustPayload acct (JRational amt)) _) ->
            Right [CommandEntry $ adjustAccountBS acct amt]
        Nothing ->
            Left $ JSON.encode $ commandResponseFailure "" "Malformed input, could not decode input JSON."
  where
    adjustAccountBS acct amt = BSC.pack $ "AdjustAccount " ++ T.unpack acct ++ " " ++ show (toRational amt)

transactReqHandler :: BLC.ByteString -> Either BLC.ByteString [CommandEntry]
transactReqHandler bs =
    case JSON.decode bs of
      Just (TransactRequest (TransactBody code _body) _) ->
          Right [CommandEntry $ BSC.pack $ T.unpack code]
      Nothing ->
          Left $ JSON.encode $ commandResponseFailure "" "Malformed input, could not decode input JSON."

ledgerQueryReqHandler :: BLC.ByteString -> Either BLC.ByteString [CommandEntry]
ledgerQueryReqHandler bs =
    case JSON.decode bs of
      Just (LedgerQueryRequest (LedgerQueryBody (QueryJson acct tx sender receiver)) _) -> do
         let mByBoth = ByAcctName Both <$> acct
         let mSwiftId =  BySwiftId <$> tx
         let mBySender = ByAcctName Sender <$> sender
         let mByReceiver = ByAcctName Receiver <$> receiver
         let query = And $ catMaybes [mSwiftId, mBySender, mByReceiver, mByBoth]
         Right [CommandEntry $ BLC.toStrict $ encode query]
      Nothing ->
         Left $ JSON.encode $ commandResponseFailure "" "Malformed input, could not decode input JSON."

cmdBatchHandler :: BLC.ByteString -> Either BLC.ByteString [CommandEntry]
cmdBatchHandler bs =
    case JSON.decode bs of
      Just (CommandBatchRequest (CommandBatch cmds) _) ->
        -- or catMaybes depending if one fails, all fail?
        case sequence $ fmap (mJsonBsToCommand . BLC.pack . T.unpack) cmds of
          Just cmds' -> Right $ fmap CommandEntry cmds'
          Nothing -> Left errorBadCommand
      Nothing -> Left errorBadCommandBatch
 where
   errorBadCommand = JSON.encode $ commandResponseFailure "" "Malformed cmd or cmds in the submitted batch, could not decode input JSON."
   errorBadCommandBatch = JSON.encode $ commandResponseFailure "" "Malformed input, could not decode input JSON."

-- TODO: _aiCmdStatusMap needs to be updated by Juno protocol this is never updated
-- poll for a list of cmdIds, returning the applied results or error
-- see juno/jmeter/juno_API_jmeter_test.jmx
pollForResults :: ReaderT ApiEnv Snap ()
pollForResults = do
    maybePoll <- liftM JSON.decode (readRequestBody 1000000)
    modifyResponse $ setHeader "Content-Type" "application/json"
    case maybePoll of
      Just (PollPayloadRequest (PollPayload cmdids) _) -> do
        env <- ask
        (CommandMap _ m) <- liftIO $ readMVar (_aiCmdStatusMap env)
        let rids = (RequestId . read . T.unpack) <$> cleanInput cmdids
        let results = PollResponse $ fmap (toRepresentation . flipIt m) rids
        writeBS . BLC.toStrict $ JSON.encode results
      Nothing -> writeBS . BLC.toStrict . JSON.encode $ commandResponseFailure "" "Malformed input, could not decode input JSON."
  where
    -- for now allow "" (empty) cmdIds
    cleanInput = filter (/=T.empty)

    flipIt :: Map RequestId CommandStatus ->  RequestId -> Maybe (RequestId, CommandStatus)
    flipIt m rId = (fmap . fmap) (\cmd -> (rId, cmd)) (`Map.lookup` m) rId

    toRepresentation :: Maybe (RequestId, CommandStatus) -> PollResult
    toRepresentation (Just (RequestId rid, cmdStatus)) =
        cmdStatus2PollResult (RequestId rid) cmdStatus
    toRepresentation Nothing = cmdStatusError

swiftSubmission :: ReaderT ApiEnv Snap ()
swiftSubmission = do
  (ApiEnv aiToCommands aiCmdStatusMap) <- ask
  bdy <- readRequestBody 1000000
  cmd <- return $ BLC.toStrict bdy
  logError $ "swiftSubmission: " <> cmd
  let unparsedSwift = decodeUtf8 cmd
  case parseSwift unparsedSwift of
    -- TODO: get to work with `errDone 400 $`
    Left err ->
        writeBS $ BLC.toStrict $ encode $
                object ["status" .= ("Failure" :: T.Text), "reason" .= err]
    Right v -> do
      -- TODO: maybe the swift blob should be serialized vs json-ified
      let blob = SwiftBlob unparsedSwift $ swiftToHopper v
      rId <- liftIO $ setNextCmdRequestId aiCmdStatusMap
      liftIO $ writeChan aiToCommands (rId, [CommandEntry $ BLC.toStrict $ encode blob])
      resp <- liftIO $ waitForCommand aiCmdStatusMap rId
      logError $ "swiftSubmission: " <> resp
      modifyResponse $ setHeader "Content-Type" "application/json"
      writeBS resp

getIntegerParam :: MonadSnap f => BSC.ByteString -> f (Maybe Integer)
getIntegerParam p = (>>= fmap fst . BSC.readInteger) <$> getQueryParam p

getTextParam :: MonadSnap f => BSC.ByteString -> f (Maybe T.Text)
getTextParam p = fmap decodeUtf8 <$> getQueryParam p

ledgerQuery :: ReaderT ApiEnv Snap ()
ledgerQuery = do
  (ApiEnv aiToCommands aiCmdStatusMap) <- ask
  mBySwift <- fmap BySwiftId <$> getIntegerParam "tx"
  mBySender <- fmap (ByAcctName Sender) <$> getTextParam "sender"
  mByReceiver <- fmap (ByAcctName Receiver) <$> getTextParam "receiver"
  mByBoth <- fmap (ByAcctName Both) <$> getTextParam "account"
  let query = And $ catMaybes [mBySwift, mBySender, mByReceiver, mByBoth]
  -- TODO: if you are querying the ledger should we wait for the command to be applied here?
  rId <- liftIO $ setNextCmdRequestId aiCmdStatusMap
  liftIO $ writeChan aiToCommands (rId, [CommandEntry $ BLC.toStrict $ encode query])
  resp <- liftIO $ waitForCommand aiCmdStatusMap rId
  modifyResponse $ setHeader "Content-Type" "application/json"
  writeBS resp

swiftHandler :: ReaderT ApiEnv Snap ()
swiftHandler = do
  (ApiEnv aiToCommands aiCmdStatusMap) <- ask
  bdy <- readRequestBody 1000000
  cmd <- return $ BLC.toStrict bdy
  logError $ "swiftHandler: " <> cmd
  case parseSwift $ decodeUtf8 cmd of
     -- TODO: get to work with `errDone 400 $`
    Left err -> writeBS $ BLC.toStrict $ encode $
                object ["status" .= ("Failure" :: T.Text), "reason" .= err]
    Right v -> do
        rId <- liftIO $ setNextCmdRequestId aiCmdStatusMap
        liftIO $ writeChan aiToCommands (rId, [CommandEntry $ BSC.pack (swiftToHopper v)])
        resp <- liftIO $ waitForCommand aiCmdStatusMap rId
        modifyResponse $ setHeader "Content-Type" "application/json"
        logError $ "swiftHandler: SUCCESS: " <> resp
        writeBS resp

swiftToHopper :: SWIFT -> String
swiftToHopper m = hopperProgram to' from' inter' amt'
  where
    to' :: String
    to' = T.unpack $ view (sCode59a . bcAccount) m
    from' :: String
    from' = T.unpack $ dirtyPickOutAccount50a m
    intermediaries :: [String]
    intermediaries = ["100","101","102","103"]
    branchA2BranchB = intercalate "->" intermediaries
    branchB2BranchA = intercalate "->" (reverse intermediaries)
    det71a = view sCode71A m
    inter' = case det71a of
               Beneficiary -> branchB2BranchA
               _ -> branchA2BranchB
    amt' :: Ratio Int
    amt' = fromIntegral (view (sCode32A . vcsSettlementAmount . vWhole) m) + view (sCode32A . vcsSettlementAmount . vPart) m
    hopperProgram :: String -> String -> String -> Ratio Int -> String
    hopperProgram t f i a = "transfer(" ++ f ++ "->" ++ i ++ "->" ++ t ++ "," ++ show a ++ ")"

hopperHandler :: ReaderT ApiEnv Snap ()
hopperHandler = do
  (ApiEnv aiToCommands aiCmdStatusMap) <- ask
  bdy <- readRequestBody 1000000
  logError $ "hopper: " <> BLC.toStrict bdy
  cmd <- return $ BLC.toStrict bdy
  case readHopper cmd of
    -- TODO: get to work with `errDone 400 $`
    Left err -> writeBS $ BSC.pack err
    Right _ -> do
      rId <- liftIO $ setNextCmdRequestId aiCmdStatusMap
      liftIO $ writeChan aiToCommands (rId, [CommandEntry cmd])
      resp <- liftIO $ waitForCommand aiCmdStatusMap rId
      writeBS resp

-- wait for the command to be present in the MVar (used by hopperHandler, swiftHandler, etc.)
waitForCommand :: CommandMVarMap -> RequestId -> IO BSC.ByteString
waitForCommand cmdMap rId =
  threadDelay 1000 >> do
    (CommandMap _ m) <- readMVar cmdMap
    case Map.lookup rId m of
      Nothing -> return $ BSC.pack $ "RequestId [" ++ show rId ++ "] not found."
      Just (CmdApplied (CommandResult bs) _lat) ->
        return bs
      Just _ -> -- not applied yet, loop and wait
        waitForCommand cmdMap rId
