{-# 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 Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

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 :: FileId -> StateT (Bimap FileIdent FileId) DB FileIdent
          recordFile fId = do
            prev <- State.gets $ Bimap.lookupR fId
            case prev of
              Just fIdent -> return fIdent
              Nothing -> do
                mTitle <- lift . E.selectMaybe . E.from $ \file -> do
                  E.where_ $ file E.^. FileId E.==. E.val fId
                  return $ file E.^. FileTitle
                cMap <- State.get
                let candidateIdents = map (review _Wrapped . CI.mk) $ case mTitle of
                      Just (E.Value fTitle)
                        -> map pack $ fTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fTitle ]
                      Nothing
                        -> [ [st|file_#{n}|] | n <- [1..] :: [Natural]]
                    fIdent = case filter (`Bimap.notMember` cMap) candidateIdents of
                               fIdent' : _ -> fIdent'
                               [] -> error "candidateIdents should be infinite; cMap should be finite"
                State.modify $ Bimap.insert fIdent fId
                return fIdent

      (wdfGraph, Bimap.toMap -> wdfFiles) <- (runStateT ?? Bimap.empty) . ($ workflowDefinitionGraph)
        $ (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey SqlBackendKey) (WorkflowGraph FileIdent SqlBackendKey) SqlBackendKey FileIdent) (recordFile . review _SqlKey)
        >=> (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph FileIdent SqlBackendKey) (WorkflowGraph FileIdent CryptoUUIDUser) 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 :: Traversal (WorkflowGraph FileIdent CryptoUUIDUser) (WorkflowGraph SqlBackendKey CryptoUUIDUser) FileIdent SqlBackendKey) (view _SqlKey . (wdfFiles !))
        & (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey CryptoUUIDUser) (WorkflowGraph SqlBackendKey SqlBackendKey) CryptoUUIDUser SqlBackendKey) (fmap (view _SqlKey :: UserId -> SqlBackendKey) . 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