module Handler.Utils.Workflow.Form
  ( FileIdent
  , WorkflowGraphForm(..)
  , workflowGraphForm
  , toWorkflowGraphForm, fromWorkflowGraphForm
  , WorkflowDescriptionsFormScope(..)
  , workflowDescriptionsForm
  ) where

import Import
import Utils.Form

import Handler.Utils.Form

import qualified Data.Conduit.Combinators as C

import qualified Data.Map as Map
import Data.Map ((!))
import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI

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

import qualified Control.Monad.State.Class as State

import qualified Data.List.NonEmpty as NonEmpty

import qualified Data.Aeson as JSON

import Utils.Workflow.Lint


newtype FileIdent = FileIdent (CI Text)
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving newtype (ToMessage, ToJSON, FromJSON)

makeWrapped ''FileIdent

newtype instance FileReferenceTitleMap FileIdent add = FileIdentFileReferenceTitleMap
  { unFileIdentFileReferenceTitleMap :: Map FilePath (FileIdentFileReferenceTitleMapElem add)
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
    deriving newtype (Semigroup, Monoid)
data FileIdentFileReferenceTitleMapElem add = FileIdentFileReferenceTitleMapElem
  { fIdentTitleMapIdent      :: FileIdent
  , fIdentTitleMapAdditional :: add
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
makePrisms ''FileIdentFileReferenceTitleMapElem

instance FileReferenceTitleMapConvertible add FileIdent FileIdent where
  _FileReferenceTitleMap = iso unFileIdentFileReferenceTitleMap FileIdentFileReferenceTitleMap . traverse . _FileIdentFileReferenceTitleMapElem

instance FileReferenceTitleMapConvertible add FileIdent FileReference where
  _FileReferenceTitleMap = iso unFileIdentFileReferenceTitleMap FileReferenceFileReferenceTitleMap . iso Map.toList Map.fromList . traverse . iso (view $ _2 . _FileIdentFileReferenceTitleMapElem) (\(FileReference{..}, additional) -> (fileReferenceTitle, FileReferenceFileReferenceTitleMapElem fileReferenceContent fileReferenceModified additional))

instance FileReferenceTitleMapConvertible add FileReference FileIdent where
  _FileReferenceTitleMap = iso unFileReferenceFileReferenceTitleMap FileIdentFileReferenceTitleMap . itraverse . (\f fileReferenceTitle FileReferenceFileReferenceTitleMapElem{ fRefTitleMapContent = fileReferenceContent, fRefTitleMapModified = fileReferenceModified, fRefTitleMapAdditional } -> review _FileIdentFileReferenceTitleMapElem <$> f (FileReference{..}, fRefTitleMapAdditional))

instance ToJSON (FileField FileIdent) where
  toJSON FileField{..} = JSON.object $ catMaybes 
    [ ("ident" JSON..=) <$> fieldIdent
    , pure $ "unpack-zips" JSON..= fieldUnpackZips
    , pure $ "multiple" JSON..= fieldMultiple
    , pure $ "restrict-extensions" JSON..= fieldRestrictExtensions
    , pure $ "max-file-size" JSON..= fieldMaxFileSize
    , pure $ "additional-files" JSON..= addFiles'
    ]
    where addFiles' = unFileIdentFileReferenceTitleMap fieldAdditionalFiles <&> \FileIdentFileReferenceTitleMapElem{..} -> JSON.object
            [ "ident" JSON..= fIdentTitleMapIdent
            , "include" JSON..= fIdentTitleMapAdditional
            ]
instance FromJSON (FileField FileIdent) where
  parseJSON = JSON.withObject "FileField" $ \o -> do
    fieldIdent <- o JSON..:? "ident"
    fieldUnpackZips <- o JSON..: "unpack-zips"
    fieldMultiple <- o JSON..: "multiple"
    fieldRestrictExtensions <- o JSON..:? "restrict-extensions"
    fieldMaxFileSize <- o JSON..:? "max-file-size"
    fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True
    addFiles' <- o JSON..:? "additional-files" JSON..!= mempty
    fieldAdditionalFiles <- fmap FileIdentFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileIdentFileReferenceTitleMapElem" $ \o' -> do
      fIdentTitleMapIdent <- o' JSON..: "Ident"
      fIdentTitleMapAdditional <- o' JSON..: "include"
      return FileIdentFileReferenceTitleMapElem{..} 
    return FileField{..}
  
  
  
data WorkflowGraphForm = WorkflowGraphForm
  { wgfGraph :: WorkflowGraph FileIdent CryptoUUIDUser
  , wgfFiles :: Map FileIdent FileReference
  } deriving (Generic, Typeable)

makeLenses_ ''WorkflowGraphForm


workflowGraphForm :: Maybe WorkflowGraphForm -> AForm DB WorkflowGraphForm
workflowGraphForm template = validateAForm validateWorkflowGraphForm . hoistAForm lift $ WorkflowGraphForm
  <$> areq yamlField (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
  <*> filesForm
  where
    filesForm = Map.fromList <$> massInputAccumEditA fileAdd fileEdit (const Nothing) fileLayout ("workflow-definition-files" :: Text) (fslI MsgWorkflowDefinitionFiles) False (Map.toList . wgfFiles <$> template)
      where fileAdd nudge submitView csrf = do
              (formRes, formView) <- fileForm nudge Nothing csrf
              MsgRenderer mr <- getMsgRenderer
              let res' = formRes <&> \newFile@(newFileIdent, _) oldFiles -> if
                    | any (\(oldFileIdent, _) -> newFileIdent == oldFileIdent) oldFiles
                      -> FormFailure [mr MsgWorkflowDefinitionFileIdentExists]
                    | otherwise
                      -> FormSuccess $ pure newFile
              return (res', $(widgetFile "widgets/massinput/workflowDefinitionFiles/add"))
            fileEdit nudge = fileForm nudge . Just
            fileForm :: (Text -> Text) -> Maybe (FileIdent, FileReference) -> Form (FileIdent, FileReference)
            fileForm nudge fileTemplate csrf = do
              (fileIdentRes, fileIdentView) <- mpreq (isoField _Unwrapped ciField) (fslI MsgWorkflowDefinitionFileIdent & addName (nudge "ident")) (view _1 <$> fileTemplate)
              (fileRes, fileView) <- mpreq (singleFileField $ maybe (return ()) (views _2 yield) fileTemplate) (fslI MsgWorkflowDefinitionFile & addName (nudge "file")) (views _2 yield <$> fileTemplate)
              fileRes' <- liftHandler . runDB $ case fileRes of
                FormSuccess uploads -> maybe FormMissing FormSuccess <$> runConduit (transPipe liftHandler uploads .| C.head)
                FormFailure errs -> return $ FormFailure errs
                FormMissing -> return FormMissing
              return ((,) <$> fileIdentRes <*> fileRes', $(widgetFile "widgets/massinput/workflowDefinitionFiles/form"))
            fileLayout :: MassInputLayout ListLength (FileIdent, FileReference) (FileIdent, FileReference)
            fileLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDefinitionFiles/layout")

validateWorkflowGraphForm :: FormValidator WorkflowGraphForm DB ()
validateWorkflowGraphForm = do
  fIdentsReferenced <- uses _wgfGraph . setOf $ typesCustom @WorkflowChildren
  fIdentsAvailable <- uses _wgfFiles Map.keysSet
  forM_ (fIdentsReferenced `Set.difference` fIdentsAvailable) $ tellValidationError . MsgWorkflowFileIdentDoesNotExist . views _Wrapped CI.original

  graph <- use _wgfGraph
  for_ (lintWorkflowGraph graph) $ \lintIssues -> do
    addMessageModal Warning (i18n MsgWorkflowDefinitionWarningLinterIssuesMessage) $ Right
      [whamlet|
        $newline never
        _{MsgWorkflowDefinitionWarningLinterIssues}
        <ul>
          $forall issue <- otoList lintIssues
            <li>
              #{displayException issue}
      |]

toWorkflowGraphForm :: ( MonadHandler m, HandlerSite m ~ UniWorX
                       )
                    => WorkflowGraph FileReference SqlBackendKey
                    -> m WorkflowGraphForm
toWorkflowGraphForm g = liftHandler . fmap (uncurry WorkflowGraphForm . over _2 Bimap.toMap) . (runStateT ?? Bimap.empty) . ($ g)
    $ traverseOf (typesCustom @WorkflowChildren) recordFile
  >=> traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileIdent SqlBackendKey) @_ @_ @CryptoUUIDUser) (encrypt . review (_SqlKey @User))
  where
    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 . pack) $
                fileReferenceTitle : [ base <.> show n <.> ext | let (base, ext) = splitExtension fileReferenceTitle, 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 fRef
          return fIdent

fromWorkflowGraphForm :: (MonadHandler m, HandlerSite m ~ UniWorX)
                      => WorkflowGraphForm
                      -> m (WorkflowGraph FileReference SqlBackendKey)
fromWorkflowGraphForm WorkflowGraphForm{..}
  = liftHandler $ wgfGraph
  & over (typesCustom @WorkflowChildren) (wgfFiles !)
  & traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)


data WorkflowDescriptionsFormScope
  = WorkflowDescriptionsFormDefinition
  | WorkflowDescriptionsFormInstance
  deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable)
  deriving (Universe, Finite)
  
workflowDescriptionsForm :: WorkflowDescriptionsFormScope -> Maybe (Map Lang (Text, Maybe StoredMarkup)) -> AForm Handler (Map Lang (Text, Maybe StoredMarkup))
workflowDescriptionsForm scope template = Map.fromList <$> massInputAccumEditA descrAdd descrEdit (const Nothing) descrLayout ("workflow-descriptions" :: Text) (fslI msgWorkflowDescriptions) False (Map.toList <$> template)
  where
    descrAdd nudge submitView csrf = do
      (formRes, formView) <- descrForm nudge Nothing csrf
      MsgRenderer mr <- getMsgRenderer
      let res' = formRes <&> \newDescr@(newLang, _) oldDescrs -> if
            | any (\(oldLang, _) -> newLang == oldLang) oldDescrs
              -> FormFailure [mr msgWorkflowDescriptionsLanguageExists]
            | otherwise
              -> FormSuccess $ pure newDescr
      return (res', $(widgetFile "widgets/massinput/workflowDescriptions/add"))
    descrEdit nudge = descrForm nudge . Just
    descrForm :: (Text -> Text) -> Maybe (Lang, (Text, Maybe StoredMarkup)) -> Form (Lang, (Text, Maybe StoredMarkup))
    descrForm nudge descrTemplate csrf = do
      (langRes, langView) <- mpreq (langField False) (fslI MsgWorkflowDescriptionLanguage & addName (nudge "lang")) (fmap (view _1) descrTemplate <|> Just (NonEmpty.head appLanguages))
      (titleRes, titleView) <- mpreq textField (fslI MsgWorkflowDescriptionTitle & addName (nudge "title")) (view (_2 . _1) <$> descrTemplate)
      (descrRes, descrView) <- mopt htmlField (fslI MsgWorkflowDescription & addName (nudge "descr")) (view (_2 . _2) <$> descrTemplate)
      return ((,) <$> langRes <*> ((,) <$> titleRes <*> descrRes), $(widgetFile "widgets/massinput/workflowDescriptions/form"))
    descrLayout :: MassInputLayout ListLength (Lang, (Text, Maybe StoredMarkup)) (Lang, (Text, Maybe StoredMarkup))
    descrLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDescriptions/layout")

    msgWorkflowDescriptions = case scope of
      WorkflowDescriptionsFormDefinition -> MsgWorkflowDefinitionDescriptions
      WorkflowDescriptionsFormInstance -> MsgWorkflowInstanceDescriptions
    msgWorkflowDescriptionsLanguageExists = case scope of
      WorkflowDescriptionsFormDefinition -> MsgWorkflowDefinitionDescriptionsLanguageExists
      WorkflowDescriptionsFormInstance -> MsgWorkflowInstanceDescriptionsLanguageExists