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

import Import
import Utils.Form
import Utils.Workflow

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

import qualified Data.Yaml as Yaml

import Control.Monad.Catch.Pure (runCatch)

import Handler.Utils.Files (sourceFile)


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{..}
  
  
  
type FormWorkflowGraph = WorkflowGraph FileIdent CryptoUUIDUser
  
data WorkflowGraphForm = WorkflowGraphForm
  { wgfGraph :: FormWorkflowGraph
  , wgfFiles :: Map FileIdent FileReference
  } deriving (Generic, Typeable)

makeLenses_ ''WorkflowGraphForm

data WorkflowGraphFormMode = WGFTextInput | WGFFileUpload
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite)
nullaryPathPiece ''WorkflowGraphFormMode $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''WorkflowGraphFormMode id


workflowGraphForm :: Maybe WorkflowGraphForm -> AForm DB WorkflowGraphForm
workflowGraphForm template = validateAForm validateWorkflowGraphForm . hoistAForm lift $ WorkflowGraphForm
  <$> multiActionA (mapF wgfGraphOptions) (fslI MsgWorkflowDefinitionGraph) (Just WGFFileUpload)
  <*> filesForm
  where
    wgfGraphOptions = \case
      WGFTextInput -> apreq yamlField (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
      WGFFileUpload -> apreq (checkMMap toGraph fromGraph . singleFileField . foldMap fromGraph $ wgfGraph <$> template) (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
      where
        toGraph :: FileUploads -> Handler (Either (SomeMessage UniWorX) FormWorkflowGraph)
        toGraph uploads = runExceptT $ do
          fRefs <- lift . runConduit $ uploads .| C.take 2 .| C.foldMap pure
          fRef <- case fRefs of
            [fRef] -> return fRef
            _other -> throwE $ SomeMessage MsgWorkflowGraphFormInvalidNumberOfFiles
          mContent <- for (fileContent $ sourceFile fRef) $ \fContent -> lift . runDB . runConduit $ fContent .| C.fold
          content <- maybe (throwE $ SomeMessage MsgWorkflowGraphFormUploadIsDirectory) return mContent
          either (throwE . SomeMessage . MsgYAMLFieldDecodeFailure . displayException) return . runCatch $ Yaml.decodeThrow content
        fromGraph :: FormWorkflowGraph -> FileUploads
        fromGraph g = yieldM . runDB $ do
          fileModified <- liftIO getCurrentTime
          fRef <- sinkFile $ File
            { fileTitle = "graph.yaml"
            , fileContent = Just . yield $ Yaml.encode g
            , fileModified
            }
          insert_ SessionFile
            { sessionFileContent = fileReferenceContent fRef
            , sessionFileTouched = fileReferenceModified fRef
            }
          return fRef
    
    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
                       )
                    => DBWorkflowGraph
                    -> 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 DBWorkflowGraph
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)

nullaryPathPiece ''WorkflowDescriptionsFormScope $ camelToPathPiece' 3
  
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--" <> toPathPiece scope :: 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
