module Handler.Workflow.Workflow.Workflow
  ( getGWWWorkflowR, postGWWWorkflowR, getGWWFilesR
  , getSWWWorkflowR, postSWWWorkflowR, getSWWFilesR
  , workflowR
  , WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor
  ) where

import Import hiding (Last(..), Encoding(None))

import Utils.Form
import Utils.Workflow

import Data.Semigroup (Last(..))

import Handler.Utils
import Handler.Utils.Workflow.EdgeForm
import Handler.Utils.Workflow.CanonicalRoute
import Handler.Utils.Workflow.Workflow

import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Sequence as Seq

import qualified Control.Monad.State.Class as State
import Control.Monad.Trans.RWS.Strict (RWST)

import qualified Crypto.Saltine.Class as Saltine
import qualified Data.Binary as Binary
import qualified Data.ByteArray as BA
import Crypto.Hash.Algorithms (SHAKE256)

import qualified Data.Text as Text
import Data.RFC5051 (compareUnicode)

import qualified Data.Scientific as Scientific
import Text.Blaze (toMarkup)
import Data.Void (absurd)

import qualified Data.Conduit.Combinators as C


data WorkflowHistoryItemActor' user = WHIASelf | WHIAOther (Maybe user) | WHIAHidden | WHIAGone
  deriving (Eq, Ord, Functor, Traversable, Foldable, Generic, Typeable)
type WorkflowHistoryItemActor = WorkflowHistoryItemActor' (Entity User)
  
data WorkflowHistoryItem = WorkflowHistoryItem
  { whiUser :: Maybe WorkflowHistoryItemActor
  , whiTime :: UTCTime
  , whiPayloadChanges :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
  , whiFrom :: Maybe (Maybe (Text, Maybe Icon)) -- ^ outer maybe encodes existence, inner maybe encodes permission to view
  , whiVia :: Maybe Text
  , whiTo :: Maybe (Text, Maybe Icon)
  } deriving (Generic, Typeable)

data WorkflowCurrentState = WorkflowCurrentState
  { wcsState :: Maybe (Text, Maybe Icon)
  , wcsMessages :: Set Message
  , wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
  }

makePrisms ''WorkflowHistoryItemActor'


getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
getGWWWorkflowR = postGWWWorkflowR
postGWWWorkflowR = workflowR WSGlobal

getGWWFilesR :: CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
getGWWFilesR = getWorkflowFilesR WSGlobal

getSWWWorkflowR, postSWWWorkflowR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
getSWWWorkflowR = postSWWWorkflowR
postSWWWorkflowR ssh = workflowR $ WSSchool ssh

getSWWFilesR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
getSWWFilesR ssh = getWorkflowFilesR $ WSSchool ssh


workflowR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
workflowR rScope cID = do
  (mEdge, (workflowState, workflowHistory)) <- runDB $ do
    wwId <- decrypt cID
    WorkflowWorkflow{..} <- get404 wwId
    maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope
    mEdgeForm <- workflowEdgeForm (Right wwId) Nothing
    wGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph
    let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)

    mEdge <- for mEdgeForm $ \edgeForm -> do
      ((edgeRes, edgeView), edgeEnc) <- liftHandler . runFormPost $ renderAForm FormStandard edgeForm
      edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
        nState <- followEdge wGraph edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState

        wInstance <- for workflowWorkflowInstance $ \wiId -> do
          wInstance@WorkflowInstance{..} <- get404 wiId
          wiScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
          return (wiScope, Entity wiId wInstance)

        update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ]

        return . Just $ do
          whenIsJust wInstance $ \(wiScope, Entity _ WorkflowInstance{..}) -> do
            memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers workflowInstanceName wiScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId))
            memcachedByInvalidate (NavCacheHaveWorkflowWorkflowsRoles wiScope) $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow), WorkflowRole UserId))
            when (isTopWorkflowScope wiScope) $
              memcachedByInvalidate NavCacheHaveTopWorkflowWorkflowsRoles $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow, RouteWorkflowScope), WorkflowRole UserId))
          memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
          memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))

          addMessageI Success MsgWorkflowWorkflowWorkflowEdgeSuccess

          redirect canonRoute
      return ((edgeAct, edgeView), edgeEnc)

    (fmap getLast -> workflowState, workflowHistory) <-
      let go :: forall m.
                ( MonadHandler m
                , HandlerSite m ~ UniWorX
                , MonadCatch m
                , MonadUnliftIO m
                )
             => WorkflowActionInfo FileReference UserId
             -> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) ()
          go WorkflowActionInfo{ waiIx = stIx, waiFrom = wpFrom, waiHistory = history@(workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..} } = maybeT (return ()) $ do
            mAuthId <- maybeAuthId
            
            stCID <- encryptWorkflowStateIndex wwId stIx
            let nodeView nodeLbl = do
                  WGN{..} <- hoistMaybe $ Map.lookup nodeLbl wgNodes
                  WorkflowNodeView{..} <- hoistMaybe wgnViewers
                  guardM $ anyM (otoList wnvViewers) hasWorkflowRole'
                  (, wgnFinal) <$> selectLanguageI18n wnvDisplayLabel
                whiTime = wpTime
                mVia = Map.lookup wpVia . wgnEdges =<< Map.lookup wpTo wgNodes
                hasWorkflowRole' role = $cachedHereBinary (rScope, wwId, role) . lift . lift $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
            
            whiTo <- lift . runMaybeT $ nodeView wpTo
            let wcsState = whiTo

            whiUser <- for wpUser $ \wpUser' -> if
              | is _Just mAuthId
              , wpUser' == mAuthId -> return WHIASelf
              | otherwise -> lift . maybeT (return WHIAHidden) $ do
                  viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
                  guardM $ anyM (otoList viewActors) hasWorkflowRole'
                  resUser <- lift . lift $ traverse getEntity wpUser'
                  return $ case resUser of
                    Nothing          -> WHIAOther Nothing
                    Just Nothing     -> WHIAGone
                    Just (Just uEnt) -> WHIAOther $ Just uEnt
  
            whiVia <- traverse selectLanguageI18n $ preview _wgeDisplayLabel =<< mVia
            whiFrom <- for wpFrom $ lift . runMaybeT . nodeView

            let renderPayload payload = do
                  sBoxKey <- secretBoxKey
                  let payloadLabelToDigest :: WorkflowPayloadLabel -> ByteString
                      payloadLabelToDigest = BA.convert . kmaclazy @(SHAKE256 256) ("workflow-workflow-payload-sorting" :: ByteString) (Saltine.encode sBoxKey) . Binary.encode . (wwId, )
                      payloadLabelSort = (compareUnicode `on` views (_2 . _1) Text.toLower)
                                      <>  comparing (views _1 payloadLabelToDigest)
                  payload' <- fmap (map (view _2) . sortBy payloadLabelSort) . forMaybeM (Map.toList payload) $ \(payloadLbl, newPayload) -> do
                    WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes)
                    guardM . $cachedHereBinary payloadLbl . anyM (otoList wpvViewers) $ lift . hasWorkflowRole'
                    let fRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID (WWFilesR payloadLbl stCID))
                    (payloadLbl, ) . (, (newPayload, fRoute)) <$> selectLanguageI18n wpvDisplayLabel
                  let
                    payloadSort :: WorkflowFieldPayloadW Void (Maybe (Entity User))
                                -> WorkflowFieldPayloadW Void (Maybe (Entity User))
                                -> Ordering
                    payloadSort = workflowPayloadSort ordFiles ordUsers
                      where
                        ordFiles = absurd
                        ordUsers a' b' = case (a', b') of
                          (Nothing, _) -> GT
                          (_, Nothing) -> LT
                          (Just (Entity _ uA), Just (Entity _ uB))
                            -> (compareUnicode `on` userSurname) uA uB
                            <> (compareUnicode `on` userDisplayName) uA uB
                            <> comparing userIdent uA uB
                  
                  forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl . bool Nothing (Just fRoute) . getAny) <=< execWriterT @_ @(_, Any) . forM_ payloads $ \case
                    WorkflowFieldPayloadW (WFPText   t  ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
                    WorkflowFieldPayloadW (WFPNumber n  ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
                    WorkflowFieldPayloadW (WFPBool   b  ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
                    WorkflowFieldPayloadW (WFPDay    d  ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
                    WorkflowFieldPayloadW (WFPFile   _  ) -> tell (mempty, Any True)
                    WorkflowFieldPayloadW (WFPUser   uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
            
            payloadChanges <- State.state $ \oldPayload ->
              ( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload
              , currentPayload
              )
            whiPayloadChanges <- renderPayload payloadChanges
            wcsPayload <- renderPayload currentPayload

            wcsMessages <- do
              let msgs = maybe Set.empty wgnMessages $ Map.lookup wpTo wgNodes
              flip foldMapM msgs $ \WorkflowNodeMessage{..} -> lift . maybeT (return Set.empty) . fmap Set.singleton $ do
                guardM $ anyM (otoList wnmViewers) hasWorkflowRole'
                history' <- hoistMaybe . fromNullable $ Seq.fromList history
                whenIsJust wnmRestriction $ guard . checkWorkflowRestriction (Just history')
                let messageStatus = wnmStatus
                    messageIcon = Nothing
                messageContent <- selectLanguageI18n wnmContent
                return Message{..}

            tell ( Just $ Last WorkflowCurrentState{..}
                 , pure WorkflowHistoryItem{..}
                 )
          WorkflowGraph{..} = wGraph
          wState = review _DBWorkflowState workflowWorkflowState
       in fmap (over _2 (sortOn (Down . whiTime) . reverse) . view _2) . runConduit $ sourceWorkflowActionInfos wwId wState .| execRWSC () Map.empty (C.mapM_ go)
    return (mEdge, (workflowState, workflowHistory))

  sequenceOf_ (_Just . _1 . _1 . _Just) mEdge

  (heading, title) <- case rScope of
    WSGlobal -> return (MsgGlobalWorkflowWorkflowWorkflowHeading cID, MsgGlobalWorkflowWorkflowWorkflowTitle cID)
    WSSchool ssh -> return (MsgSchoolWorkflowWorkflowWorkflowHeading ssh cID, MsgSchoolWorkflowWorkflowWorkflowTitle ssh cID)
    _other -> error "not implemented"
  let headingWgt
        | Just WorkflowCurrentState{..} <- workflowState
        , Just (_, Just icn) <- wcsState
        = [whamlet|_{heading}&nbsp;#{icon icn}|]
        | otherwise = i18n heading

  siteLayout headingWgt $ do
    setTitleI title
    let mEdgeView = mEdge <&> \((_, edgeView'), edgeEnc) -> wrapForm edgeView' FormSettings
          { formMethod = POST
          , formAction = Just . SomeRoute $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
          , formEncoding = edgeEnc
          , formAttrs = []
          , formSubmit = FormSubmit
          , formAnchor = Nothing :: Maybe Text
          }
        historyToWidget WorkflowHistoryItem{..} = $(widgetFile "workflows/workflow/history-item")
        payloadToWidget :: WorkflowFieldPayloadW Void (Maybe (Entity User)) -> Widget
        payloadToWidget = \case
          WorkflowFieldPayloadW (WFPText   t       )
            -> [whamlet|
                 $newline never
                 <p .workflow-payload--text>
                   #{t}
               |]
          WorkflowFieldPayloadW (WFPNumber n       ) -> toWidget . toMarkup $ formatScientific Scientific.Fixed Nothing n
          WorkflowFieldPayloadW (WFPBool   b       ) -> i18n $ WorkflowPayloadBool b
          WorkflowFieldPayloadW (WFPDay    d       ) -> formatTimeW SelFormatDate d
          WorkflowFieldPayloadW (WFPUser   mUserEnt) -> case mUserEnt of
            Nothing                  -> i18n MsgWorkflowPayloadUserGone
            Just (Entity _ User{..}) -> nameWidget userDisplayName userSurname
          WorkflowFieldPayloadW (WFPFile   v       ) -> absurd v
    $(widgetFile "workflows/workflow")

getWorkflowFilesR :: RouteWorkflowScope
                  -> CryptoFileNameWorkflowWorkflow
                  -> WorkflowPayloadLabel
                  -> CryptoUUIDWorkflowStateIndex
                  -> Handler TypedContent
getWorkflowFilesR rScope wwCID wpl stCID = do
  fRefs <- runDB $ do
    wwId <- decrypt wwCID
    WorkflowWorkflow{..} <- get404 wwId
    maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope
    stIx <- decryptWorkflowStateIndex wwId stCID
    payloads <- maybeT notFound . workflowStateSection stIx $ _DBWorkflowState # workflowWorkflowState
    mAuthId <- maybeAuthId
    payloads' <- fmap (Map.findWithDefault Set.empty wpl . workflowStateCurrentPayloads) . filterM (mayViewWorkflowAction mAuthId wwId) $ otoList payloads
    let
      payloads'' :: [FileReference]
      payloads'' = payloads' ^.. folded . _WorkflowFieldPayloadW . _WorkflowFieldPayload
    when (null payloads'') notFound
    return payloads''

  archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgWorkflowWorkflowFilesArchiveName wwCID wpl stCID

  serveSomeFiles archiveName $ yieldMany fRefs
