{-# LANGUAGE BangPatterns #-}

module Handler.Workflow.Definition.Edit
  ( getAWDEditR, postAWDEditR
  ) where

import Import
import Handler.Utils
import Handler.Workflow.Definition.Form

import qualified Data.Map as Map
import Data.Map.Strict ((!))

import Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap

import qualified Control.Monad.State.Class as State

import qualified Data.CaseInsensitive as CI


getAWDEditR, postAWDEditR :: WorkflowInstanceScope' -> WorkflowDefinitionName -> Handler Html
getAWDEditR = postAWDEditR
postAWDEditR wds' wdn = do
  (((_, editForm), editEncoding), act) <- runDB $ do
    Entity wdId WorkflowDefinition{..} <- getBy404 $ UniqueWorkflowDefinition wdn wds'
    template <- do
      descs <- selectList [WorkflowDefinitionDescriptionDefinition ==. wdId] []
      let wdfDescriptions = Map.fromList
            [ (workflowDefinitionDescriptionLanguage, (workflowDefinitionDescriptionTitle, workflowDefinitionDescriptionDescription))
            | Entity _ WorkflowDefinitionDescription{..} <- descs
            ]

      let recordFile :: forall m. Monad m => FileReference -> StateT (Bimap FileIdent FileReference) m FileIdent
          recordFile fRef@FileReference{..} = do
            prev <- State.gets $ Bimap.lookupR fRef
            case prev of
              Just fIdent -> return fIdent
              Nothing -> do
                cMap <- State.get
                let candidateIdents = map (review _Wrapped . CI.mk) $
                      map pack $ fileReferenceTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fileReferenceTitle ]
                    fIdent = case filter (`Bimap.notMember` cMap) candidateIdents of
                               fIdent' : _ -> fIdent'
                               [] -> error "candidateIdents should be infinite; cMap should be finite"
                State.modify $ Bimap.insert fIdent fRef
                return fIdent

      (wdfGraph, Bimap.toMap -> wdfFiles) <- (runStateT ?? Bimap.empty) . ($ workflowDefinitionGraph)
          $ traverseOf (typesCustom @WorkflowChildren) recordFile
        >=> traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileIdent SqlBackendKey) @_ @_ @CryptoUUIDUser) (encrypt . review (_SqlKey @User))

      return WorkflowDefinitionForm
        { wdfScope = workflowDefinitionScope
        , wdfName = workflowDefinitionName
        , wdfDescriptions
        , wdfGraph
        , wdfFiles
        }
    
    form@((editRes, _), _) <- runFormPost . workflowDefinitionForm $ Just template

    act <- formResultMaybe editRes $ \WorkflowDefinitionForm{..} -> do
      wdfGraph' <- wdfGraph
        & over (typesCustom @WorkflowChildren) (wdfFiles !)
        & traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)
      
      insConflict <- replaceUnique wdId WorkflowDefinition
        { workflowDefinitionGraph = wdfGraph'
        , workflowDefinitionScope = wdfScope
        , workflowDefinitionName = wdfName
        }

      when (is _Nothing insConflict) . iforM_ wdfDescriptions $ \wddLang (wddTitle, wddDesc) -> do
        deleteWhere [WorkflowDefinitionDescriptionDefinition ==. wdId]
        insert WorkflowDefinitionDescription
          { workflowDefinitionDescriptionDefinition = wdId
          , workflowDefinitionDescriptionLanguage = wddLang
          , workflowDefinitionDescriptionTitle = wddTitle
          , workflowDefinitionDescriptionDescription = wddDesc
          }

      case insConflict of
        Just (UniqueWorkflowDefinition wdn' wds'') -> return . Just $
          addMessage' =<< messageIHamlet Error
            [ihamlet|
              $newline never
              <a href=@{AdminWorkflowDefinitionR wds'' wdn' AWDEditR}>
                _{MsgWorkflowDefinitionCollision}
            |]
        Nothing -> return . Just $ do
          addMessageI Success MsgWorkflowDefinitionEdited
          redirect AdminWorkflowDefinitionListR

    return (form, act)
  
  forM_ act id

  let editWidget = wrapForm editForm def
        { formAction = Just . SomeRoute $ AdminWorkflowDefinitionR wds' wdn AWDEditR
        , formEncoding = editEncoding
        }

  siteLayoutMsg MsgWorkflowDefinitionEditTitle $ do
    setTitleI MsgWorkflowDefinitionEditTitle

    editWidget